1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2015 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;
71 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();
111 jquery-ui-1.10.0.custom.min.js
112 jquery-ui-timepicker-addon.js
113 jquery-ui-patch-datepicker.js
115 jquery.modal-defaults.js
121 jquery.event.hover-1.0.js
124 jquery.supposition.js
128 event-registration.js
130 /static/RichText/ckeditor.js
131 }, RT->Config->Get('JSFiles');
136 Removes the cached CSS and JS entries, forcing them to be regenerated
146 =head2 EscapeHTML SCALARREF
148 does a css-busting but minimalist escaping of whatever html you're passing in.
154 return unless defined $$ref;
156 $$ref =~ s/&/&/g;
159 $$ref =~ s/\(/(/g;
160 $$ref =~ s/\)/)/g;
161 $$ref =~ s/"/"/g;
162 $$ref =~ s/'/'/g;
169 Instead => "EscapeHTML",
175 =head2 EscapeURI SCALARREF
177 Escapes URI component according to RFC2396
183 return unless defined $$ref;
186 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
189 =head2 EncodeJSON SCALAR
191 Encodes the SCALAR to JSON and returns a JSON Unicode (B<not> UTF-8) string.
192 SCALAR may be a simple value or a reference.
197 my $s = JSON::to_json(shift, { allow_nonref => 1 });
202 sub _encode_surrogates {
203 my $uni = $_[0] - 0x10000;
204 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
209 return unless defined $$ref;
211 $$ref = "'" . join('',
213 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
214 $_ <= 255 ? sprintf("\\x%02X", $_) :
215 $_ <= 65535 ? sprintf("\\u%04X", $_) :
216 sprintf("\\u%X\\u%X", _encode_surrogates($_))
217 } unpack('U*', $$ref))
221 =head2 WebCanonicalizeInfo();
223 Different web servers set different environmental varibles. This
224 function must return something suitable for REMOTE_USER. By default,
225 just downcase $ENV{'REMOTE_USER'}
229 sub WebCanonicalizeInfo {
230 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
235 =head2 WebRemoteUserAutocreateInfo($user);
237 Returns a hash of user attributes, used when WebRemoteUserAutocreate is set.
241 sub WebRemoteUserAutocreateInfo {
246 # default to making Privileged users, even if they specify
247 # some other default Attributes
248 if ( !$RT::UserAutocreateDefaultsOnLogin
249 || ( ref($RT::UserAutocreateDefaultsOnLogin) && not exists $RT::UserAutocreateDefaultsOnLogin->{Privileged} ) )
251 $user_info{'Privileged'} = 1;
254 # Populate fields with information from Unix /etc/passwd
255 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
256 $user_info{'Comments'} = $comments if defined $comments;
257 $user_info{'RealName'} = $realname if defined $realname;
259 # and return the wad of stuff
267 if (RT->Config->Get('DevelMode')) {
268 require Module::Refresh;
269 Module::Refresh->refresh;
272 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
274 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
276 # Roll back any dangling transactions from a previous failed connection
277 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
279 MaybeEnableSQLStatementLog();
281 # avoid reentrancy, as suggested by masonbook
282 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
284 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
285 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
290 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
291 PreprocessTimeUpdates($ARGS);
294 MaybeShowInstallModePage();
296 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
299 if ( _UserLoggedIn() ) {
300 # make user info up to date
301 $HTML::Mason::Commands::session{'CurrentUser'}
302 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
303 undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
306 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
309 # Process session-related callbacks before any auth attempts
310 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
312 MaybeRejectPrivateComponentRequest();
314 MaybeShowNoAuthPage($ARGS);
316 AttemptExternalAuth($ARGS) if RT->Config->Get('WebRemoteUserContinuous') or not _UserLoggedIn();
318 _ForceLogout() unless _UserLoggedIn();
320 # Process per-page authentication callbacks
321 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
323 if ( $ARGS->{'NotMobile'} ) {
324 $HTML::Mason::Commands::session{'NotMobile'} = 1;
327 unless ( _UserLoggedIn() ) {
330 # Authenticate if the user is trying to login via user/pass query args
331 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
334 my $m = $HTML::Mason::Commands::m;
336 # REST urls get a special 401 response
337 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
338 $HTML::Mason::Commands::r->content_type("text/plain; charset=utf-8");
339 $m->error_format("text");
340 $m->out("RT/$RT::VERSION 401 Credentials required\n");
341 $m->out("\n$msg\n") if $msg;
344 # Specially handle /index.html and /m/index.html so that we get a nicer URL
345 elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
346 my $mobile = $1 ? 1 : 0;
347 my $next = SetNextPage($ARGS);
348 $m->comp('/NoAuth/Login.html',
355 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
360 MaybeShowInterstitialCSRFPage($ARGS);
362 # now it applies not only to home page, but any dashboard that can be used as a workspace
363 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
364 if ( $ARGS->{'HomeRefreshInterval'} );
366 # Process per-page global callbacks
367 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
369 ShowRequestedPage($ARGS);
370 LogRecordedSQLStatements(RequestData => {
371 Path => $HTML::Mason::Commands::m->request_path,
374 # Process per-page final cleanup callbacks
375 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
377 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
378 unless $HTML::Mason::Commands::r->content_type
379 =~ qr<^(text|application)/(x-)?(css|javascript)>;
384 delete $HTML::Mason::Commands::session{'CurrentUser'};
388 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
396 =head2 LoginError ERROR
398 Pushes a login error into the Actions session store and returns the hash key.
404 my $key = Digest::MD5::md5_hex( rand(1024) );
405 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
406 $HTML::Mason::Commands::session{'i'}++;
410 =head2 SetNextPage ARGSRef [PATH]
412 Intuits and stashes the next page in the sesssion hash. If PATH is
413 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
420 my $next = $_[0] ? $_[0] : IntuitNextPage();
421 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
422 my $page = { url => $next };
424 # If an explicit URL was passed and we didn't IntuitNextPage, then
425 # IsPossibleCSRF below is almost certainly unrelated to the actual
426 # destination. Currently explicit next pages aren't used in RT, but the
428 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
429 # This isn't really CSRF, but the CSRF heuristics are useful for catching
430 # requests which may have unintended side-effects.
431 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
434 "Marking original destination as having side-effects before redirecting for login.\n"
436 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
438 $page->{'HasSideEffects'} = [$msg, @loc];
442 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
443 $HTML::Mason::Commands::session{'i'}++;
447 =head2 FetchNextPage HASHKEY
449 Returns the stashed next page hashref for the given hash.
454 my $hash = shift || "";
455 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
458 =head2 RemoveNextPage HASHKEY
460 Removes the stashed next page for the given hash and returns it.
465 my $hash = shift || "";
466 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
469 =head2 TangentForLogin ARGSRef [HASH]
471 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
472 the next page. Takes a hashref of request %ARGS as the first parameter.
473 Optionally takes all other parameters as a hash which is dumped into query
478 sub TangentForLogin {
479 my $login = TangentForLoginURL(@_);
480 Redirect( RT->Config->Get('WebBaseURL') . $login );
483 =head2 TangentForLoginURL [HASH]
485 Returns a URL suitable for tangenting for login. Optionally takes a hash which
486 is dumped into query params.
490 sub TangentForLoginURL {
492 my $hash = SetNextPage($ARGS);
493 my %query = (@_, next => $hash);
496 if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
498 my $login = RT->Config->Get('WebPath') . '/NoAuth/Login.html?';
499 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
503 =head2 TangentForLoginWithError ERROR
505 Localizes the passed error message, stashes it with L<LoginError> and then
506 calls L<TangentForLogin> with the appropriate results key.
510 sub TangentForLoginWithError {
512 my $key = LoginError(HTML::Mason::Commands::loc(@_));
513 TangentForLogin( $ARGS, results => $key );
516 =head2 IntuitNextPage
518 Attempt to figure out the path to which we should return the user after a
519 tangent. The current request URL is used, or failing that, the C<WebURL>
520 configuration variable.
527 # This includes any query parameters. Redirect will take care of making
528 # it an absolute URL.
529 if ($ENV{'REQUEST_URI'}) {
530 $req_uri = $ENV{'REQUEST_URI'};
532 # collapse multiple leading slashes so the first part doesn't look like
533 # a hostname of a schema-less URI
534 $req_uri =~ s{^/+}{/};
537 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
540 my $uri = URI->new($next);
542 # You get undef scheme with a relative uri like "/Search/Build.html"
543 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
544 $next = RT->Config->Get('WebURL');
547 # Make sure we're logging in to the same domain
548 # You can get an undef authority with a relative uri like "index.html"
549 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
550 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
551 $next = RT->Config->Get('WebURL');
557 =head2 MaybeShowInstallModePage
559 This function, called exclusively by RT's autohandler, dispatches
560 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
562 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
566 sub MaybeShowInstallModePage {
567 return unless RT->InstallMode;
569 my $m = $HTML::Mason::Commands::m;
570 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
572 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
573 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
580 =head2 MaybeShowNoAuthPage \%ARGS
582 This function, called exclusively by RT's autohandler, dispatches
583 a request to the page a user requested (but only if it matches the "noauth" regex.
585 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
589 sub MaybeShowNoAuthPage {
592 my $m = $HTML::Mason::Commands::m;
594 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
596 # Don't show the login page to logged in users
597 Redirect(RT->Config->Get('WebURL'))
598 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
600 # If it's a noauth file, don't ask for auth.
601 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
605 =head2 MaybeRejectPrivateComponentRequest
607 This function will reject calls to private components, like those under
608 C</Elements>. If the requested path is a private component then we will
609 abort with a C<403> error.
613 sub MaybeRejectPrivateComponentRequest {
614 my $m = $HTML::Mason::Commands::m;
615 my $path = $m->request_comp->path;
617 # We do not check for dhandler here, because requesting our dhandlers
618 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
624 _elements | # mobile UI
627 autohandler | # requesting this directly is suspicious
628 l (_unsafe)? ) # loc component
629 ( $ | / ) # trailing slash or end of path
631 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
634 warn "rejecting private component $path\n";
642 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
643 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
644 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
649 =head2 ShowRequestedPage \%ARGS
651 This function, called exclusively by RT's autohandler, dispatches
652 a request to the page a user requested (making sure that unpriviled users
653 can only see self-service pages.
657 sub ShowRequestedPage {
660 my $m = $HTML::Mason::Commands::m;
662 # Ensure that the cookie that we send is up-to-date, in case the
663 # session-id has been modified in any way
666 # precache all system level rights for the current user
667 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
669 # If the user isn't privileged, they can only see SelfService
670 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
672 # if the user is trying to access a ticket, redirect them
673 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
674 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
677 # otherwise, drop the user at the SelfService default page
678 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
679 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
682 # if user is in SelfService dir let him do anything
684 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
687 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
692 sub AttemptExternalAuth {
695 return unless ( RT->Config->Get('WebRemoteUserAuth') );
697 my $user = $ARGS->{user};
698 my $m = $HTML::Mason::Commands::m;
700 my $logged_in_external_user = _UserLoggedIn() && $HTML::Mason::Commands::session{'WebExternallyAuthed'};
702 # If RT is configured for external auth, let's go through and get REMOTE_USER
704 # Do we actually have a REMOTE_USER or equivalent? We only check auth if
705 # 1) we have no logged in user, or 2) we have a user who is externally
706 # authed. If we have a logged in user who is internally authed, don't
707 # check remote user otherwise we may log them out.
708 if (RT::Interface::Web::WebCanonicalizeInfo()
709 and (not _UserLoggedIn() or $logged_in_external_user) )
711 $user = RT::Interface::Web::WebCanonicalizeInfo();
712 my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load';
714 my $next = RemoveNextPage($ARGS->{'next'});
715 $next = $next->{'url'} if ref $next;
716 InstantiateNewSession() unless _UserLoggedIn;
717 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
718 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
720 if ( RT->Config->Get('WebRemoteUserAutocreate') and not _UserLoggedIn() ) {
722 # Create users on-the-fly
723 my $UserObj = RT::User->new(RT->SystemUser);
724 my ( $val, $msg ) = $UserObj->Create(
725 %{ ref RT->Config->Get('UserAutocreateDefaultsOnLogin') ? RT->Config->Get('UserAutocreateDefaultsOnLogin') : {} },
732 # now get user specific information, to better create our user.
733 my $new_user_info = RT::Interface::Web::WebRemoteUserAutocreateInfo($user);
735 # set the attributes that have been defined.
736 foreach my $attribute ( $UserObj->WritableAttributes, qw(Privileged Disabled) ) {
738 Attribute => $attribute,
740 UserInfo => $new_user_info,
741 CallbackName => 'NewUser',
742 CallbackPage => '/autohandler'
744 my $method = "Set$attribute";
745 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
747 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
749 RT->Logger->error("Couldn't auto-create user '$user' when attempting WebRemoteUser: $msg");
750 AbortExternalAuth( Error => "UserAutocreateDefaultsOnLogin" );
754 if ( _UserLoggedIn() ) {
755 $HTML::Mason::Commands::session{'WebExternallyAuthed'} = 1;
756 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
757 # It is possible that we did a redirect to the login page,
758 # if the external auth allows lack of auth through with no
759 # REMOTE_USER set, instead of forcing a "permission
760 # denied" message. Honor the $next.
761 Redirect($next) if $next;
762 # Unlike AttemptPasswordAuthentication below, we do not
763 # force a redirect to / if $next is not set -- otherwise,
764 # straight-up external auth would always redirect to /
765 # when you first hit it.
767 # Couldn't auth with the REMOTE_USER provided because an RT
768 # user doesn't exist and we're configured not to create one.
769 RT->Logger->error("Couldn't find internal user for '$user' when attempting WebRemoteUser and RT is not configured for auto-creation. Refer to `perldoc $RT::BasePath/docs/authentication.pod` if you want to allow auto-creation.");
771 Error => "NoInternalUser",
776 elsif ($logged_in_external_user) {
777 # The logged in external user was deauthed by the auth system and we
778 # should kick them out.
779 AbortExternalAuth( Error => "Deauthorized" );
781 elsif (not RT->Config->Get('WebFallbackToRTLogin')) {
782 # Abort if we don't want to fallback internally
783 AbortExternalAuth( Error => "NoRemoteUser" );
787 sub AbortExternalAuth {
789 my $error = $args{Error} ? "/Errors/WebRemoteUser/$args{Error}" : undef;
790 my $m = $HTML::Mason::Commands::m;
791 my $r = $HTML::Mason::Commands::r;
795 # Clear the decks, not that we should have partial content.
799 $m->comp($error, %args)
800 if $error and $m->comp_exists($error);
802 # Return a 403 Forbidden or we may fallback to a login page with no form
806 sub AttemptPasswordAuthentication {
808 return unless defined $ARGS->{user} && defined $ARGS->{pass};
810 my $user_obj = RT::CurrentUser->new();
811 $user_obj->Load( $ARGS->{user} );
813 my $m = $HTML::Mason::Commands::m;
815 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
816 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
817 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
818 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
821 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
823 # It's important to nab the next page from the session before we blow
825 my $next = RemoveNextPage($ARGS->{'next'});
826 $next = $next->{'url'} if ref $next;
828 InstantiateNewSession();
829 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
831 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next );
833 # Really the only time we don't want to redirect here is if we were
834 # passed user and pass as query params in the URL.
838 elsif ($ARGS->{'next'}) {
839 # Invalid hash, but still wants to go somewhere, take them to /
840 Redirect(RT->Config->Get('WebURL'));
843 return (1, HTML::Mason::Commands::loc('Logged in'));
847 =head2 LoadSessionFromCookie
849 Load or setup a session cookie for the current user.
853 sub _SessionCookieName {
854 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
855 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
859 sub LoadSessionFromCookie {
861 my %cookies = CGI::Cookie->fetch;
862 my $cookiename = _SessionCookieName();
863 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
864 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
865 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
866 InstantiateNewSession();
868 if ( int RT->Config->Get('AutoLogoff') ) {
869 my $now = int( time / 60 );
870 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
872 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
873 InstantiateNewSession();
876 # save session on each request when AutoLogoff is turned on
877 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
881 sub InstantiateNewSession {
882 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
883 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
887 sub SendSessionCookie {
888 my $cookie = CGI::Cookie->new(
889 -name => _SessionCookieName(),
890 -value => $HTML::Mason::Commands::session{_session_id},
891 -path => RT->Config->Get('WebPath'),
892 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
893 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
896 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
899 =head2 GetWebURLFromRequest
901 People may use different web urls instead of C<$WebURL> in config.
902 Return the web url current user is using.
906 sub GetWebURLFromRequest {
908 my $uri = URI->new( RT->Config->Get('WebURL') );
910 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
911 $uri->scheme('https');
914 $uri->scheme('http');
917 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
918 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} );
919 $uri->port( $ENV{'SERVER_PORT'} );
920 return "$uri"; # stringify to be consistent with WebURL in config
925 This routine ells the current user's browser to redirect to URL.
926 Additionally, it unties the user's currently active session, helping to avoid
927 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
928 a cached DBI statement handle twice at the same time.
933 my $redir_to = shift;
934 untie $HTML::Mason::Commands::session;
935 my $uri = URI->new($redir_to);
936 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
938 # Make relative URIs absolute from the server host and scheme
939 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
940 if (not defined $uri->host) {
941 $uri->host($server_uri->host);
942 $uri->port($server_uri->port);
945 # If the user is coming in via a non-canonical
946 # hostname, don't redirect them to the canonical host,
947 # it will just upset them (and invalidate their credentials)
948 # don't do this if $RT::CanonicalizeRedirectURLs is true
949 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
950 && $uri->host eq $server_uri->host
951 && $uri->port eq $server_uri->port )
953 my $env_uri = URI->new(GetWebURLFromRequest());
954 $uri->scheme($env_uri->scheme);
955 $uri->host($env_uri->host);
956 $uri->port($env_uri->port);
959 # not sure why, but on some systems without this call mason doesn't
960 # set status to 302, but 200 instead and people see blank pages
961 $HTML::Mason::Commands::r->status(302);
963 # Perlbal expects a status message, but Mason's default redirect status
964 # doesn't provide one. See also rt.cpan.org #36689.
965 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
967 $HTML::Mason::Commands::m->abort;
970 =head2 GetStaticHeaders
972 return an arrayref of Headers (currently, Cache-Control and Expires).
976 sub GetStaticHeaders {
979 my $Visibility = 'private';
980 if ( ! defined $args{Time} ) {
982 } elsif ( $args{Time} eq 'no-cache' ) {
984 } elsif ( $args{Time} eq 'forever' ) {
985 $args{Time} = 30 * 24 * 60 * 60;
986 $Visibility = 'public';
989 my $CacheControl = $args{Time}
990 ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
994 my $expires = RT::Date->new(RT->SystemUser);
996 $expires->AddSeconds( $args{Time} ) if $args{Time};
999 Expires => $expires->RFC2616,
1000 'Cache-Control' => $CacheControl,
1004 =head2 CacheControlExpiresHeaders
1006 set both Cache-Control and Expires http headers
1010 sub CacheControlExpiresHeaders {
1011 Plack::Util::header_iter( GetStaticHeaders(@_), sub {
1012 my ( $key, $val ) = @_;
1013 $HTML::Mason::Commands::r->headers_out->{$key} = $val;
1017 =head2 StaticFileHeaders
1019 Send the browser a few headers to try to get it to (somewhat agressively)
1020 cache RT's static Javascript and CSS files.
1022 This routine could really use _accurate_ heuristics. (XXX TODO)
1026 sub StaticFileHeaders {
1027 # remove any cookie headers -- if it is cached publicly, it
1028 # shouldn't include anyone's cookie!
1029 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
1031 # Expire things in a month.
1032 CacheControlExpiresHeaders( Time => 'forever' );
1035 =head2 ComponentPathIsSafe PATH
1037 Takes C<PATH> and returns a boolean indicating that the user-specified partial
1038 component path is safe.
1040 Currently "safe" means that the path does not start with a dot (C<.>), does
1041 not contain a slash-dot C</.>, and does not contain any nulls.
1045 sub ComponentPathIsSafe {
1048 return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
1053 Takes a C<< Path => path >> and returns a boolean indicating that
1054 the path is safely within RT's control or not. The path I<must> be
1057 This function does not consult the filesystem at all; it is merely
1058 a logical sanity checking of the path. This explicitly does not handle
1059 symlinks; if you have symlinks in RT's webroot pointing outside of it,
1060 then we assume you know what you are doing.
1067 my $path = $args{Path};
1069 # Get File::Spec to clean up extra /s, ./, etc
1070 my $cleaned_up = File::Spec->canonpath($path);
1072 if (!defined($cleaned_up)) {
1073 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
1077 # Forbid too many ..s. We can't just sum then check because
1078 # "../foo/bar/baz" should be illegal even though it has more
1079 # downdirs than updirs. So as soon as we get a negative score
1080 # (which means "breaking out" of the top level) we reject the path.
1082 my @components = split '/', $cleaned_up;
1084 for my $component (@components) {
1085 if ($component eq '..') {
1088 $RT::Logger->info("Rejecting unsafe path: $path");
1092 elsif ($component eq '.' || $component eq '') {
1093 # these two have no effect on $score
1103 =head2 SendStaticFile
1105 Takes a File => path and a Type => Content-type
1107 If Type isn't provided and File is an image, it will
1108 figure out a sane Content-type, otherwise it will
1109 send application/octet-stream
1111 Will set caching headers using StaticFileHeaders
1115 sub SendStaticFile {
1118 my $file = $args{File};
1119 my $type = $args{Type};
1120 my $relfile = $args{RelativeFile};
1122 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1123 $HTML::Mason::Commands::r->status(400);
1124 $HTML::Mason::Commands::m->abort;
1127 $self->StaticFileHeaders();
1130 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1132 $type =~ s/jpg/jpeg/gi;
1134 $type ||= "application/octet-stream";
1136 $HTML::Mason::Commands::r->content_type($type);
1137 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1141 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1142 $HTML::Mason::Commands::m->flush_buffer;
1153 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'}) {
1164 my $content = $args{Content};
1165 return '' unless $content;
1167 # Make the content have no 'weird' newlines in it
1168 $content =~ s/\r+\n/\n/g;
1170 my $return_content = $content;
1172 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1173 my $sigonly = $args{StripSignature};
1175 # massage content to easily detect if there's any real content
1176 $content =~ s/\s+//g; # yes! remove all the spaces
1178 # remove html version of spaces and newlines
1179 $content =~ s! !!g;
1180 $content =~ s!<br/?>!!g;
1183 # Filter empty content when type is text/html
1184 return '' if $html && $content !~ /\S/;
1186 # If we aren't supposed to strip the sig, just bail now.
1187 return $return_content unless $sigonly;
1189 # Find the signature
1190 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1193 # Check for plaintext sig
1194 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1196 # Check for html-formatted sig; we don't use EscapeHTML here
1197 # because we want to precisely match the escapting that FCKEditor
1199 $sig =~ s/&/&/g;
1202 $sig =~ s/"/"/g;
1203 $sig =~ s/'/'/g;
1204 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1207 return $return_content;
1213 # Later in the code we use
1214 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1215 # instead of $m->call_next to avoid problems with UTF8 keys in
1216 # arguments. Specifically, the call_next method pass through
1217 # original arguments, which are still the encoded bytes, not
1218 # characters. "{ base_comp => $m->request_comp }" is copied from
1219 # mason's source to get the same results as we get from call_next
1220 # method; this feature is not documented.
1223 # if they've passed multiple values, they'll be an array. if they've
1224 # passed just one, a scalar whatever they are, mark them as utf8
1227 ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
1228 : ( $type eq 'ARRAY' )
1229 ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
1230 : ( $type eq 'HASH' )
1231 ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
1236 sub PreprocessTimeUpdates {
1239 # This code canonicalizes time inputs in hours into minutes
1240 foreach my $field ( keys %$ARGS ) {
1241 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1243 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1244 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1245 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1246 $ARGS->{$local} *= 60;
1248 delete $ARGS->{$field};
1253 sub MaybeEnableSQLStatementLog {
1255 my $log_sql_statements = RT->Config->Get('StatementLog');
1257 if ($log_sql_statements) {
1258 $RT::Handle->ClearSQLStatementLog;
1259 $RT::Handle->LogSQLStatements(1);
1264 sub LogRecordedSQLStatements {
1267 my $log_sql_statements = RT->Config->Get('StatementLog');
1269 return unless ($log_sql_statements);
1271 my @log = $RT::Handle->SQLStatementLog;
1272 $RT::Handle->ClearSQLStatementLog;
1274 $RT::Handle->AddRequestToHistory({
1275 %{ $args{RequestData} },
1279 for my $stmt (@log) {
1280 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1290 level => $log_sql_statements,
1292 . sprintf( "%.6f", $duration )
1294 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1300 my $_has_validated_web_config = 0;
1301 sub ValidateWebConfig {
1304 # do this once per server instance, not once per request
1305 return if $_has_validated_web_config;
1306 $_has_validated_web_config = 1;
1308 my $port = $ENV{SERVER_PORT};
1309 my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1310 || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
1311 ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1313 if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1314 $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
1315 ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1316 ."otherwise your internal links may be broken.");
1319 if ( $host ne RT->Config->Get('WebDomain') ) {
1320 $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
1321 ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1322 ."otherwise your internal links may be broken.");
1325 return; #next warning flooding our logs, doesn't seem applicable to our use
1326 # (SCRIPT_NAME is the full path, WebPath is just the beginning)
1327 #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
1329 # Unfortunately, there is no reliable way to get the _path_ that was
1330 # requested at the proxy level; simply disable this warning if we're
1331 # proxied and there's a mismatch.
1332 my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1333 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1334 $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
1335 ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1336 ."otherwise your internal links may be broken.");
1340 sub ComponentRoots {
1342 my %args = ( Names => 0, @_ );
1344 if (defined $HTML::Mason::Commands::m) {
1345 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1348 [ local => $RT::MasonLocalComponentRoot ],
1349 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1350 [ standard => $RT::MasonComponentRoot ]
1353 @roots = map { $_->[1] } @roots unless $args{Names};
1360 $RT::LocalStaticPath,
1361 (map { $_->StaticDir } @{RT->Plugins}),
1364 return grep { $_ and -d $_ } @static;
1367 our %is_whitelisted_component = (
1368 # The RSS feed embeds an auth token in the path, but query
1369 # information for the search. Because it's a straight-up read, in
1370 # addition to embedding its own auth, it's fine.
1371 '/NoAuth/rss/dhandler' => 1,
1373 # While these can be used for denial-of-service against RT
1374 # (construct a very inefficient query and trick lots of users into
1375 # running them against RT) it's incredibly useful to be able to link
1376 # to a search result (or chart) or bookmark a result page.
1377 '/Search/Results.html' => 1,
1378 '/Search/Simple.html' => 1,
1379 '/m/tickets/search' => 1,
1380 '/Search/Chart.html' => 1,
1381 '/User/Search.html' => 1,
1383 # This page takes Attachment and Transaction argument to figure
1384 # out what to show, but it's read only and will deny information if you
1385 # don't have ShowOutgoingEmail.
1386 '/Ticket/ShowEmailRecord.html' => 1,
1389 # Components which are blacklisted from automatic, argument-based whitelisting.
1390 # These pages are not idempotent when called with just an id.
1391 our %is_blacklisted_component = (
1392 # Takes only id and toggles bookmark state
1393 '/Helpers/Toggle/TicketBookmark' => 1,
1396 sub IsCompCSRFWhitelisted {
1400 return 1 if $is_whitelisted_component{$comp};
1402 my %args = %{ $ARGS };
1404 # If the user specifies a *correct* user and pass then they are
1405 # golden. This acts on the presumption that external forms may
1406 # hardcode a username and password -- if a malicious attacker knew
1407 # both already, CSRF is the least of your problems.
1408 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1409 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1410 my $user_obj = RT::CurrentUser->new();
1411 $user_obj->Load($args{user});
1412 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1418 # Some pages aren't idempotent even with safe args like id; blacklist
1419 # them from the automatic whitelisting below.
1420 return 0 if $is_blacklisted_component{$comp};
1422 # Eliminate arguments that do not indicate an effectful request.
1423 # For example, "id" is acceptable because that is how RT retrieves a
1427 # If they have a results= from MaybeRedirectForResults, that's also fine.
1428 delete $args{results};
1430 # The homepage refresh, which uses the Refresh header, doesn't send
1431 # a referer in most browsers; whitelist the one parameter it reloads
1432 # with, HomeRefreshInterval, which is safe
1433 delete $args{HomeRefreshInterval};
1435 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1436 # in the session related to which interface you get.
1437 delete $args{NotMobile};
1439 # If there are no arguments, then it's likely to be an idempotent
1440 # request, which are not susceptible to CSRF
1446 sub IsRefererCSRFWhitelisted {
1447 my $referer = _NormalizeHost(shift);
1448 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1449 $base_url = $base_url->host_port;
1452 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1453 push @$configs,$config;
1455 my $host_port = $referer->host_port;
1456 if ($config =~ /\*/) {
1457 # Turn a literal * into a domain component or partial component match.
1458 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1459 my $regex = join "[a-zA-Z0-9\-]*",
1460 map { quotemeta($_) }
1461 split /\*/, $config;
1463 return 1 if $host_port =~ /^$regex$/i;
1465 return 1 if $host_port eq $config;
1469 return (0,$referer,$configs);
1472 =head3 _NormalizeHost
1474 Takes a URI and creates a URI object that's been normalized
1475 to handle common problems such as localhost vs 127.0.0.1
1479 sub _NormalizeHost {
1481 $s = "http://$s" unless $s =~ /^http/i;
1482 my $uri= URI->new($s);
1483 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1489 sub IsPossibleCSRF {
1492 # If first request on this session is to a REST endpoint, then
1493 # whitelist the REST endpoints -- and explicitly deny non-REST
1494 # endpoints. We do this because using a REST cookie in a browser
1495 # would open the user to CSRF attacks to the REST endpoints.
1496 my $path = $HTML::Mason::Commands::r->path_info;
1497 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1498 unless defined $HTML::Mason::Commands::session{'REST'};
1500 if ($HTML::Mason::Commands::session{'REST'}) {
1501 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1503 This login session belongs to a REST client, and cannot be used to
1504 access non-REST interfaces of RT for security reasons.
1506 my $details = <<EOT;
1507 Please log out and back in to obtain a session for normal browsing. If
1508 you understand the security implications, disabling RT's CSRF protection
1509 will remove this restriction.
1512 HTML::Mason::Commands::Abort( $why, Details => $details );
1515 return 0 if IsCompCSRFWhitelisted(
1516 $HTML::Mason::Commands::m->request_comp->path,
1520 # if there is no Referer header then assume the worst
1522 "your browser did not supply a Referrer header", # loc
1523 ) if !$ENV{HTTP_REFERER};
1525 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1526 return 0 if $whitelisted;
1528 if ( @$configs > 1 ) {
1530 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1531 $browser->host_port,
1533 join(', ', @$configs) );
1537 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1538 $browser->host_port,
1542 sub ExpandCSRFToken {
1545 my $token = delete $ARGS->{CSRF_Token};
1546 return unless $token;
1548 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1549 return unless $data;
1550 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1552 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1553 return unless $user->ValidateAuthString( $data->{auth}, $token );
1555 %{$ARGS} = %{$data->{args}};
1556 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1558 # We explicitly stored file attachments with the request, but not in
1559 # the session yet, as that would itself be an attack. Put them into
1560 # the session now, so they'll be visible.
1561 if ($data->{attach}) {
1562 my $filename = $data->{attach}{filename};
1563 my $mime = $data->{attach}{mime};
1564 $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename}
1571 sub StoreRequestToken {
1574 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1575 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1577 auth => $user->GenerateAuthString( $token ),
1578 path => $HTML::Mason::Commands::r->path_info,
1581 if ($ARGS->{Attach}) {
1582 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1583 my $file_path = delete $ARGS->{'Attach'};
1585 # This needs to be decoded because the value is a reference;
1586 # hence it was not decoded along with all of the standard
1587 # arguments in DecodeARGS
1589 filename => Encode::decode("UTF-8", "$file_path"),
1590 mime => $attachment,
1594 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1595 $HTML::Mason::Commands::session{'i'}++;
1599 sub MaybeShowInterstitialCSRFPage {
1602 return unless RT->Config->Get('RestrictReferrer');
1604 # Deal with the form token provided by the interstitial, which lets
1605 # browsers which never set referer headers still use RT, if
1606 # painfully. This blows values into ARGS
1607 return if ExpandCSRFToken($ARGS);
1609 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1610 return if !$is_csrf;
1612 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1614 my $token = StoreRequestToken($ARGS);
1615 $HTML::Mason::Commands::m->comp(
1617 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1618 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1621 # Calls abort, never gets here
1624 our @POTENTIAL_PAGE_ACTIONS = (
1625 qr'/Ticket/Create.html' => "create a ticket", # loc
1626 qr'/Ticket/' => "update a ticket", # loc
1627 qr'/Admin/' => "modify RT's configuration", # loc
1628 qr'/Approval/' => "update an approval", # loc
1629 qr'/Articles/' => "update an article", # loc
1630 qr'/Dashboards/' => "modify a dashboard", # loc
1631 qr'/m/ticket/' => "update a ticket", # loc
1632 qr'Prefs' => "modify your preferences", # loc
1633 qr'/Search/' => "modify or access a search", # loc
1634 qr'/SelfService/Create' => "create a ticket", # loc
1635 qr'/SelfService/' => "update a ticket", # loc
1638 sub PotentialPageAction {
1640 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1641 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1642 return HTML::Mason::Commands::loc($result)
1643 if $page =~ $pattern;
1648 =head2 RewriteInlineImages PARAMHASH
1650 Turns C<< <img src="cid:..."> >> elements in HTML into working images pointing
1651 back to RT's stored copy.
1653 Takes the following parameters:
1659 Scalar ref of the HTML content to rewrite. Modified in place to support the
1660 most common use-case.
1664 The L<RT::Attachment> object from which the Content originates.
1666 =item Related (optional)
1668 Array ref of related L<RT::Attachment> objects to use for C<Content-ID> matching.
1670 Defaults to the result of the C<Siblings> method on the passed Attachment.
1672 =item AttachmentPath (optional)
1674 The base path to use when rewriting C<src> attributes.
1676 Defaults to C< $WebPath/Ticket/Attachment >
1680 In scalar context, returns the number of elements rewritten.
1682 In list content, returns the attachments IDs referred to by the rewritten <img>
1683 elements, in the order found. There may be duplicates.
1687 sub RewriteInlineImages {
1690 Attachment => undef,
1692 AttachmentPath => RT->Config->Get('WebPath')."/Ticket/Attachment",
1696 return unless defined $args{Content}
1697 and ref $args{Content} eq 'SCALAR'
1698 and defined $args{Attachment};
1700 my $related_part = $args{Attachment}->Closest("multipart/related")
1703 $args{Related} ||= $related_part->Children->ItemsArrayRef;
1704 return unless @{$args{Related}};
1706 my $content = $args{'Content'};
1709 require HTML::RewriteAttributes::Resources;
1710 $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub {
1713 return $cid unless lc $meta{tag} eq 'img'
1714 and lc $meta{attr} eq 'src'
1715 and $cid =~ s/^cid://i;
1717 for my $attach (@{$args{Related}}) {
1718 if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) {
1719 push @rewritten, $attach->Id;
1720 return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id;
1724 # No attachments means this is a bogus CID. Just pass it through.
1725 RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]);
1731 =head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1733 Returns the standard custom field input name; this is complementary to
1734 L</_ParseObjectCustomFieldArgs>. Takes the following arguments:
1738 =item CustomField => I<L<RT::CustomField> object>
1742 =item Object => I<object>
1744 The object that the custom field is applied to; optional. If omitted,
1745 defaults to a new object of the appropriate class for the custom field.
1747 =item Grouping => I<CF grouping>
1749 The grouping that the custom field is being rendered in. Groupings
1750 allow a custom field to appear in more than one location per form.
1756 sub GetCustomFieldInputName {
1758 CustomField => undef,
1764 my $name = GetCustomFieldInputNamePrefix(%args);
1766 if ( $args{CustomField}->Type eq 'Select' ) {
1767 if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
1774 elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
1777 elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
1781 if ( $args{CustomField}->SingleValue ) {
1792 =head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1794 Returns the standard custom field input name prefix(without "Value" or alike suffix)
1798 sub GetCustomFieldInputNamePrefix {
1800 CustomField => undef,
1806 my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
1807 ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
1808 'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
1809 $args{CustomField}->id, '';
1814 package HTML::Mason::Commands;
1816 use vars qw/$r $m %session/;
1818 use Scalar::Util qw(blessed);
1821 return $HTML::Mason::Commands::m->notes('menu');
1825 return $HTML::Mason::Commands::m->notes('page-menu');
1829 return $HTML::Mason::Commands::m->notes('page-widgets');
1833 my %args = (toplevel => 1, parent_id => '', depth => 0, @_);
1834 return unless $args{'menu'};
1836 my ($menu, $depth, $toplevel, $id, $parent_id)
1837 = @args{qw(menu depth toplevel id parent_id)};
1839 my $interp = $m->interp;
1840 my $web_path = RT->Config->Get('WebPath');
1843 $res .= ' ' x $depth;
1845 $res .= ' id="'. $interp->apply_escapes($id, 'h') .'"'
1847 $res .= ' class="toplevel"' if $toplevel;
1850 for my $child ($menu->children) {
1851 $res .= ' 'x ($depth+1);
1853 my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key);
1854 $item_id =~ s/\s/-/g;
1855 my $eitem_id = $interp->apply_escapes($item_id, 'h');
1856 $res .= qq{<li id="li-$eitem_id"};
1859 push @classes, 'has-children' if $child->has_children;
1860 push @classes, 'active' if $child->active;
1861 $res .= ' class="'. join( ' ', @classes ) .'"'
1866 if ( my $tmp = $child->raw_html ) {
1869 $res .= qq{<a id="$eitem_id" class="menu-item};
1870 if ( $tmp = $child->class ) {
1871 $res .= ' '. $interp->apply_escapes($tmp, 'h');
1875 my $path = $child->path;
1876 my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path;
1878 $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"';
1880 if ( $tmp = $child->target ) {
1881 $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"'
1884 if ($child->attributes) {
1885 for my $key (keys %{$child->attributes}) {
1886 my ($name, $value) = map { $interp->apply_escapes($_, 'h') }
1887 $key, $child->attributes->{$key};
1888 $res .= " $name=\"$value\"";
1893 if ( $child->escape_title ) {
1894 $res .= $interp->apply_escapes($child->title, 'h');
1896 $res .= $child->title;
1901 if ( $child->has_children ) {
1906 parent_id => $item_id,
1911 $res .= ' ' x ($depth+1);
1915 $res .= ' ' x $depth;
1917 return $res if $args{'return'};
1925 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1926 with whatever it's called with. If there is no $session{'CurrentUser'},
1927 it creates a temporary user, so we have something to get a localisation handle
1934 if ( $session{'CurrentUser'}
1935 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1937 return ( $session{'CurrentUser'}->loc(@_) );
1940 RT::CurrentUser->new();
1944 return ( $u->loc(@_) );
1947 # pathetic case -- SystemUser is gone.
1954 =head2 loc_fuzzy STRING
1956 loc_fuzzy is for handling localizations of messages that may already
1957 contain interpolated variables, typically returned from libraries
1958 outside RT's control. It takes the message string and extracts the
1959 variable array automatically by matching against the candidate entries
1960 inside the lexicon file.
1967 if ( $session{'CurrentUser'}
1968 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1970 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1972 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1973 return ( $u->loc_fuzzy($msg) );
1978 # Error - calls Error and aborts
1983 if ( $session{'ErrorDocument'}
1984 && $session{'ErrorDocumentType'} )
1986 $r->content_type( $session{'ErrorDocumentType'} );
1987 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1990 $m->comp( "/Elements/Error", Why => $why, %args );
1995 sub MaybeRedirectForResults {
1997 Path => $HTML::Mason::Commands::m->request_comp->path,
2004 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
2005 return unless $has_actions || $args{'Force'};
2007 my %arguments = %{ $args{'Arguments'} };
2009 if ( $has_actions ) {
2010 my $key = Digest::MD5::md5_hex( rand(1024) );
2011 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
2013 $arguments{'results'} = $key;
2016 $args{'Path'} =~ s!^/+!!;
2017 my $url = RT->Config->Get('WebURL') . $args{Path};
2019 if ( keys %arguments ) {
2020 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
2022 if ( $args{'Anchor'} ) {
2023 $url .= "#". $args{'Anchor'};
2025 return RT::Interface::Web::Redirect($url);
2028 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
2030 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
2031 redirect to the approvals display page, preserving any arguments.
2033 C<Path>s matching C<Whitelist> are let through.
2035 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
2039 sub MaybeRedirectToApproval {
2041 Path => $HTML::Mason::Commands::m->request_comp->path,
2047 return unless $ENV{REQUEST_METHOD} eq 'GET';
2049 my $id = $args{ARGSRef}->{id};
2052 and RT->Config->Get('ForceApprovalsView')
2053 and not $args{Path} =~ /$args{Whitelist}/)
2055 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
2058 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
2059 MaybeRedirectForResults(
2060 Path => "/Approvals/Display.html",
2062 Anchor => $args{ARGSRef}->{Anchor},
2063 Arguments => $args{ARGSRef},
2069 =head2 CreateTicket ARGS
2071 Create a new ticket, using Mason's %ARGS. returns @results.
2080 my $current_user = $session{'CurrentUser'};
2081 my $Ticket = RT::Ticket->new( $current_user );
2083 my $Queue = RT::Queue->new( $current_user );
2084 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
2085 Abort('Queue not found');
2088 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
2089 Abort('You have no permission to create tickets in that queue.');
2093 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
2094 $due = RT::Date->new( $current_user );
2095 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
2098 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
2099 $starts = RT::Date->new( $current_user );
2100 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
2103 my $sigless = RT::Interface::Web::StripContent(
2104 Content => $ARGS{Content},
2105 ContentType => $ARGS{ContentType},
2106 StripSignature => 1,
2107 CurrentUser => $current_user,
2110 my $date_now = RT::Date->new( $current_user );
2111 $date_now->SetToNow;
2112 my $MIMEObj = MakeMIMEEntity(
2113 Subject => $ARGS{'Subject'},
2114 From => $ARGS{'From'} || $current_user->EmailAddress,
2115 To => $ARGS{'To'} || $Queue->CorrespondAddress
2116 || RT->Config->Get('CorrespondAddress'),
2118 Date => $date_now->RFC2822(Timezone => 'user'),
2120 Type => $ARGS{'ContentType'},
2121 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2125 if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) {
2126 push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2128 delete $session{'Attachments'}{ $ARGS{'Token'} || '' }
2129 unless $ARGS{'KeepAttachments'};
2130 $session{'Attachments'} = $session{'Attachments'}
2133 if ( $ARGS{'Attachments'} ) {
2134 push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} };
2136 if ( @attachments ) {
2137 $MIMEObj->make_multipart;
2138 $MIMEObj->add_part( $_ ) foreach @attachments;
2141 for my $argument (qw(Encrypt Sign)) {
2142 if ( defined $ARGS{ $argument } ) {
2143 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
2148 Type => $ARGS{'Type'} || 'ticket',
2149 Queue => $ARGS{'Queue'},
2150 Owner => $ARGS{'Owner'},
2153 Requestor => $ARGS{'Requestors'},
2155 AdminCc => $ARGS{'AdminCc'},
2156 InitialPriority => $ARGS{'InitialPriority'},
2157 FinalPriority => $ARGS{'FinalPriority'},
2158 TimeLeft => $ARGS{'TimeLeft'},
2159 TimeEstimated => $ARGS{'TimeEstimated'},
2160 TimeWorked => $ARGS{'TimeWorked'},
2161 Subject => $ARGS{'Subject'},
2162 Status => $ARGS{'Status'},
2163 Due => $due ? $due->ISO : undef,
2164 Starts => $starts ? $starts->ISO : undef,
2165 MIMEObj => $MIMEObj,
2166 SquelchMailTo => $ARGS{'SquelchMailTo'},
2167 TransSquelchMailTo => $ARGS{'TransSquelchMailTo'},
2170 if ($ARGS{'DryRun'}) {
2171 $create_args{DryRun} = 1;
2172 $create_args{Owner} ||= $RT::Nobody->Id;
2173 $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress;
2174 $create_args{Subject} ||= '';
2175 $create_args{Status} ||= $Queue->Lifecycle->DefaultOnCreate,
2178 foreach my $type (qw(Requestor Cc AdminCc)) {
2179 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
2180 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
2182 push @{$create_args{TransSquelchMailTo}}, @txn_squelch;
2185 if ( $ARGS{'AttachTickets'} ) {
2186 require RT::Action::SendEmail;
2187 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2188 ref $ARGS{'AttachTickets'}
2189 ? @{ $ARGS{'AttachTickets'} }
2190 : ( $ARGS{'AttachTickets'} ) );
2193 my %cfs = ProcessObjectCustomFieldUpdatesForCreate(
2195 ContextObject => $Queue,
2198 my %links = ProcessLinksForCreate( ARGSRef => \%ARGS );
2200 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs);
2201 return $Trans if $ARGS{DryRun};
2207 push( @Actions, split( "\n", $ErrMsg ) );
2208 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
2209 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
2211 return ( $Ticket, @Actions );
2217 =head2 LoadTicket id
2219 Takes a ticket id as its only variable. if it's handed an array, it takes
2222 Returns an RT::Ticket object as the current user.
2229 if ( ref($id) eq "ARRAY" ) {
2234 Abort("No ticket specified");
2237 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2239 unless ( $Ticket->id ) {
2240 Abort("Could not load ticket $id");
2247 =head2 ProcessUpdateMessage
2249 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
2251 Don't write message if it only contains current user's signature and
2252 SkipSignatureOnly argument is true. Function anyway adds attachments
2253 and updates time worked field even if skips message. The default value
2258 # change from stock: if txn custom fields are set but there's no content
2259 # or attachment, create a Touch txn instead of doing nothing
2261 sub ProcessUpdateMessage {
2266 SkipSignatureOnly => 1,
2271 if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) {
2272 push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2274 delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' }
2275 unless $args{'KeepAttachments'};
2276 $session{'Attachments'} = $session{'Attachments'}
2279 if ( $args{ARGSRef}{'UpdateAttachments'} ) {
2280 push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_},
2281 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2284 # Strip the signature
2285 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
2286 Content => $args{ARGSRef}->{UpdateContent},
2287 ContentType => $args{ARGSRef}->{UpdateContentType},
2288 StripSignature => $args{SkipSignatureOnly},
2289 CurrentUser => $args{'TicketObj'}->CurrentUser,
2292 my %txn_customfields;
2294 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2295 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
2296 next if $key =~ /(TimeUnits|Magic)$/;
2297 $txn_customfields{$key} = $args{ARGSRef}->{$key};
2301 # If, after stripping the signature, we have no message, create a
2302 # Touch transaction if necessary
2303 if ( not @attachments
2304 and not length $args{ARGSRef}->{'UpdateContent'} )
2306 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
2307 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
2308 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
2311 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
2312 if ( $timetaken or grep {length $_} values %txn_customfields ) {
2313 my ( $Transaction, $Description, $Object ) =
2314 $args{TicketObj}->Touch(
2315 CustomFields => \%txn_customfields,
2316 TimeTaken => $timetaken
2318 return $Description;
2323 if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) {
2324 $args{ARGSRef}->{'UpdateSubject'} = undef;
2327 my $Message = MakeMIMEEntity(
2328 Subject => $args{ARGSRef}->{'UpdateSubject'},
2329 Body => $args{ARGSRef}->{'UpdateContent'},
2330 Type => $args{ARGSRef}->{'UpdateContentType'},
2331 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2334 $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2335 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2337 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2338 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2339 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2341 $old_txn = $args{TicketObj}->Transactions->First();
2344 if ( my $msg = $old_txn->Message->First ) {
2345 RT::Interface::Email::SetInReplyTo(
2346 Message => $Message,
2348 Ticket => $args{'TicketObj'},
2352 if ( @attachments ) {
2353 $Message->make_multipart;
2354 $Message->add_part( $_ ) foreach @attachments;
2357 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2358 require RT::Action::SendEmail;
2359 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2360 ref $args{ARGSRef}->{'AttachTickets'}
2361 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2362 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2365 my %message_args = (
2366 Sign => $args{ARGSRef}->{'Sign'},
2367 Encrypt => $args{ARGSRef}->{'Encrypt'},
2368 MIMEObj => $Message,
2369 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2370 CustomFields => \%txn_customfields,
2373 _ProcessUpdateMessageRecipients(
2374 MessageArgs => \%message_args,
2379 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2380 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2381 push( @results, $Description );
2382 $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2383 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2384 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2385 push( @results, $Description );
2386 $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2389 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2394 sub _ProcessUpdateMessageRecipients {
2398 MessageArgs => undef,
2402 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2403 my $cc = $args{ARGSRef}->{'UpdateCc'};
2405 my $message_args = $args{MessageArgs};
2407 $message_args->{CcMessageTo} = $cc;
2408 $message_args->{BccMessageTo} = $bcc;
2411 foreach my $type (qw(Cc AdminCc)) {
2412 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2413 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2414 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2415 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2418 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2419 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2420 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2423 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2424 $message_args->{SquelchMailTo} = \@txn_squelch
2427 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2428 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2429 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2431 my $var = ucfirst($1) . 'MessageTo';
2433 if ( $message_args->{$var} ) {
2434 $message_args->{$var} .= ", $value";
2436 $message_args->{$var} = $value;
2442 sub ProcessAttachments {
2449 my $token = $args{'ARGSRef'}{'Token'}
2450 ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) );
2452 my $update_session = 0;
2454 # deal with deleting uploaded attachments
2455 if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) {
2456 delete $session{'Attachments'}{ $token }{ $_ }
2457 foreach ref $del? @$del : ($del);
2459 $update_session = 1;
2462 # store the uploaded attachment in session
2463 my $new = $args{'ARGSRef'}{'Attach'};
2464 if ( defined $new && length $new ) {
2465 my $attachment = MakeMIMEEntity(
2466 AttachmentFieldName => 'Attach'
2469 # This needs to be decoded because the value is a reference;
2470 # hence it was not decoded along with all of the standard
2471 # arguments in DecodeARGS
2472 my $file_path = Encode::decode( "UTF-8", "$new");
2473 $session{'Attachments'}{ $token }{ $file_path } = $attachment;
2475 $update_session = 1;
2477 $session{'Attachments'} = $session{'Attachments'} if $update_session;
2481 =head2 MakeMIMEEntity PARAMHASH
2483 Takes a paramhash Subject, Body and AttachmentFieldName.
2485 Also takes Form, Cc and Type as optional paramhash keys.
2487 Returns a MIME::Entity.
2491 sub MakeMIMEEntity {
2493 #TODO document what else this takes.
2499 AttachmentFieldName => undef,
2504 my $Message = MIME::Entity->build(
2505 Type => 'multipart/mixed',
2506 "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2507 "X-RT-Interface" => $args{Interface},
2508 map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2509 grep defined $args{$_}, qw(Subject From Cc To Date)
2512 if ( defined $args{'Body'} && length $args{'Body'} ) {
2514 # Make the update content have no 'weird' newlines in it
2515 $args{'Body'} =~ s/\r\n/\n/gs;
2518 Type => $args{'Type'} || 'text/plain',
2520 Data => Encode::encode( "UTF-8", $args{'Body'} ),
2524 if ( $args{'AttachmentFieldName'} ) {
2526 my $cgi_object = $m->cgi_object;
2527 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2528 if ( defined $filehandle && length $filehandle ) {
2530 my ( @content, $buffer );
2531 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2532 push @content, $buffer;
2535 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2537 my $filename = Encode::decode("UTF-8","$filehandle");
2538 $filename =~ s{^.*[\\/]}{};
2541 Type => $uploadinfo->{'Content-Type'},
2542 Filename => Encode::encode("UTF-8",$filename),
2543 Data => \@content, # Bytes, as read directly from the file, above
2545 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2546 $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2549 # Attachment parts really shouldn't get a Message-ID or "interface"
2550 $Message->head->delete('Message-ID');
2551 $Message->head->delete('X-RT-Interface');
2555 $Message->make_singlepart;
2557 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2565 =head2 ParseDateToISO
2567 Takes a date in an arbitrary format.
2568 Returns an ISO date and time in GMT
2572 sub ParseDateToISO {
2575 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2577 Format => 'unknown',
2580 return ( $date_obj->ISO );
2585 sub ProcessACLChanges {
2586 my $ARGSref = shift;
2590 foreach my $arg ( keys %$ARGSref ) {
2591 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2593 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2596 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2597 @rights = @{ $ARGSref->{$arg} };
2599 @rights = $ARGSref->{$arg};
2601 @rights = grep $_, @rights;
2602 next unless @rights;
2604 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2605 $principal->Load($principal_id);
2608 if ( $object_type eq 'RT::System' ) {
2610 } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2611 $obj = $object_type->new( $session{'CurrentUser'} );
2612 $obj->Load($object_id);
2613 unless ( $obj->id ) {
2614 $RT::Logger->error("couldn't load $object_type #$object_id");
2618 $RT::Logger->error("object type '$object_type' is incorrect");
2619 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2623 foreach my $right (@rights) {
2624 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2625 push( @results, $msg );
2635 ProcessACLs expects values from a series of checkboxes that describe the full
2636 set of rights a principal should have on an object.
2638 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2639 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2640 listing the rights the principal should have, and ProcessACLs will modify the
2641 current rights to match. Additionally, the previously unused CheckACL input
2642 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2643 rights are removed from a principal and as such no SetRights input is
2649 my $ARGSref = shift;
2650 my (%state, @results);
2652 my $CheckACL = $ARGSref->{'CheckACL'};
2653 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2655 # Check if we want to grant rights to a previously rights-less user
2656 for my $type (qw(user group)) {
2657 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2660 unless ($principal->PrincipalId) {
2661 push @results, loc("Couldn't load the specified principal");
2665 my $principal_id = $principal->PrincipalId;
2667 # Turn our addprincipal rights spec into a real one
2668 for my $arg (keys %$ARGSref) {
2669 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2671 my $tuple = "$principal_id-$1";
2672 my $key = "SetRights-$tuple";
2674 # If we have it already, that's odd, but merge them
2675 if (grep { $_ eq $tuple } @check) {
2676 $ARGSref->{$key} = [
2677 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2678 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2681 $ARGSref->{$key} = $ARGSref->{$arg};
2682 push @check, $tuple;
2687 # Build our rights state for each Principal-Object tuple
2688 foreach my $arg ( keys %$ARGSref ) {
2689 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2692 my $value = $ARGSref->{$arg};
2693 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2694 next unless @rights;
2696 $state{$tuple} = { map { $_ => 1 } @rights };
2699 foreach my $tuple (List::MoreUtils::uniq @check) {
2700 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2702 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2704 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2705 $principal->Load($principal_id);
2708 if ( $object_type eq 'RT::System' ) {
2710 } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2711 $obj = $object_type->new( $session{'CurrentUser'} );
2712 $obj->Load($object_id);
2713 unless ( $obj->id ) {
2714 $RT::Logger->error("couldn't load $object_type #$object_id");
2718 $RT::Logger->error("object type '$object_type' is incorrect");
2719 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2723 my $acls = RT::ACL->new($session{'CurrentUser'});
2724 $acls->LimitToObject( $obj );
2725 $acls->LimitToPrincipal( Id => $principal_id );
2727 while ( my $ace = $acls->Next ) {
2728 my $right = $ace->RightName;
2730 # Has right and should have right
2731 next if delete $state{$tuple}->{$right};
2733 # Has right and shouldn't have right
2734 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2735 push @results, $msg;
2738 # For everything left, they don't have the right but they should
2739 for my $right (keys %{ $state{$tuple} || {} }) {
2740 delete $state{$tuple}->{$right};
2741 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2742 push @results, $msg;
2745 # Check our state for leftovers
2746 if ( keys %{ $state{$tuple} || {} } ) {
2747 my $missed = join '|', %{$state{$tuple} || {}};
2749 "Uh-oh, it looks like we somehow missed a right in "
2750 ."ProcessACLs. Here's what was leftover: $missed"
2758 =head2 _ParseACLNewPrincipal
2760 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2761 for the presence of rights being added on a principal of the specified type,
2762 and returns undef if no new principal is being granted rights. Otherwise loads
2763 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2764 may not be successfully loaded, and you should check C<->id> yourself.
2768 sub _ParseACLNewPrincipal {
2769 my $ARGSref = shift;
2770 my $type = lc shift;
2771 my $key = "AddPrincipalForRights-$type";
2773 return unless $ARGSref->{$key};
2776 if ( $type eq 'user' ) {
2777 $principal = RT::User->new( $session{'CurrentUser'} );
2778 $principal->LoadByCol( Name => $ARGSref->{$key} );
2780 elsif ( $type eq 'group' ) {
2781 $principal = RT::Group->new( $session{'CurrentUser'} );
2782 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2788 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2790 @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.
2792 Returns an array of success/failure messages
2796 sub UpdateRecordObject {
2799 AttributesRef => undef,
2801 AttributePrefix => undef,
2805 my $Object = $args{'Object'};
2806 my @results = $Object->Update(
2807 AttributesRef => $args{'AttributesRef'},
2808 ARGSRef => $args{'ARGSRef'},
2809 AttributePrefix => $args{'AttributePrefix'},
2817 sub ProcessCustomFieldUpdates {
2819 CustomFieldObj => undef,
2824 my $Object = $args{'CustomFieldObj'};
2825 my $ARGSRef = $args{'ARGSRef'};
2827 my @attribs = qw(Name Type Description Queue SortOrder);
2828 my @results = UpdateRecordObject(
2829 AttributesRef => \@attribs,
2834 my $prefix = "CustomField-" . $Object->Id;
2835 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2836 my ( $addval, $addmsg ) = $Object->AddValue(
2837 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2838 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2839 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2841 push( @results, $addmsg );
2845 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2846 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2847 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2849 foreach my $id (@delete_values) {
2850 next unless defined $id;
2851 my ( $err, $msg ) = $Object->DeleteValue($id);
2852 push( @results, $msg );
2855 my $vals = $Object->Values();
2856 while ( my $cfv = $vals->Next() ) {
2857 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2858 if ( $cfv->SortOrder != $so ) {
2859 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2860 push( @results, $msg );
2870 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2872 Returns an array of results messages.
2876 sub ProcessTicketBasics {
2884 my $TicketObj = $args{'TicketObj'};
2885 my $ARGSRef = $args{'ARGSRef'};
2887 my $OrigOwner = $TicketObj->Owner;
2902 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2903 for my $field (qw(Queue Owner)) {
2904 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2905 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2906 my $temp = $class->new(RT->SystemUser);
2907 $temp->Load( $ARGSRef->{$field} );
2909 $ARGSRef->{$field} = $temp->id;
2914 # Status isn't a field that can be set to a null value.
2915 # RT core complains if you try
2916 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2918 my @results = UpdateRecordObject(
2919 AttributesRef => \@attribs,
2920 Object => $TicketObj,
2921 ARGSRef => $ARGSRef,
2924 # We special case owner changing, so we can use ForceOwnerChange
2925 if ( $ARGSRef->{'Owner'}
2926 && $ARGSRef->{'Owner'} !~ /\D/
2927 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2929 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2930 $ChownType = "Force";
2936 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2937 push( @results, $msg );
2945 sub ProcessTicketReminders {
2952 my $Ticket = $args{'TicketObj'};
2953 my $args = $args{'ARGSRef'};
2956 my $reminder_collection = $Ticket->Reminders->Collection;
2958 if ( $args->{'update-reminders'} ) {
2959 while ( my $reminder = $reminder_collection->Next ) {
2960 my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve;
2961 my ( $status, $msg, $old_subject, @subresults );
2962 if ( $reminder->Status ne $resolve_status
2963 && $args->{ 'Complete-Reminder-' . $reminder->id } )
2965 ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder);
2966 push @subresults, $msg;
2968 elsif ( $reminder->Status eq $resolve_status
2969 && !$args->{ 'Complete-Reminder-' . $reminder->id } )
2971 ( $status, $msg ) = $Ticket->Reminders->Open($reminder);
2972 push @subresults, $msg;
2976 exists( $args->{ 'Reminder-Subject-' . $reminder->id } )
2977 && ( $reminder->Subject ne
2978 $args->{ 'Reminder-Subject-' . $reminder->id } )
2981 $old_subject = $reminder->Subject;
2983 $reminder->SetSubject(
2984 $args->{ 'Reminder-Subject-' . $reminder->id } );
2985 push @subresults, $msg;
2989 exists( $args->{ 'Reminder-Owner-' . $reminder->id } )
2990 && ( $reminder->Owner !=
2991 $args->{ 'Reminder-Owner-' . $reminder->id } )
2995 $reminder->SetOwner(
2996 $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" );
2997 push @subresults, $msg;
3000 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } )
3001 && $args->{ 'Reminder-Due-' . $reminder->id } ne '' )
3003 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3004 my $due = $args->{ 'Reminder-Due-' . $reminder->id };
3007 Format => 'unknown',
3010 if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
3011 ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
3014 $msg = loc( "invalid due date: [_1]", $due );
3017 push @subresults, $msg;
3020 push @results, map {
3021 loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ )
3026 if ( $args->{'NewReminder-Subject'} ) {
3027 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
3029 Format => 'unknown',
3030 Value => $args->{'NewReminder-Due'}
3032 my ( $status, $msg ) = $Ticket->Reminders->Add(
3033 Subject => $args->{'NewReminder-Subject'},
3034 Owner => $args->{'NewReminder-Owner'},
3035 Due => $due_obj->ISO
3039 loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") )
3042 push @results, $msg;
3048 sub ProcessObjectCustomFieldUpdates {
3050 my $ARGSRef = $args{'ARGSRef'};
3053 # Build up a list of objects that we want to work with
3054 my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef);
3056 # For each of those objects
3057 foreach my $class ( keys %custom_fields_to_mod ) {
3058 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
3059 my $Object = $args{'Object'};
3060 $Object = $class->new( $session{'CurrentUser'} )
3061 unless $Object && ref $Object eq $class;
3063 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3064 unless ( $Object->id ) {
3065 $RT::Logger->warning("Couldn't load object $class #$id");
3069 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3070 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3071 $CustomFieldObj->SetContextObject($Object);
3072 $CustomFieldObj->LoadById($cf);
3073 unless ( $CustomFieldObj->id ) {
3074 $RT::Logger->warning("Couldn't load custom field #$cf");
3077 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3078 if (@groupings > 1) {
3079 # Check for consistency, in case of JS fail
3080 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3081 my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3082 $base = [ $base ] unless ref $base;
3083 for my $grouping (@groupings[1..$#groupings]) {
3084 my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3085 $other = [ $other ] unless ref $other;
3086 warn "CF $cf submitted with multiple differing values"
3087 if grep {$_} List::MoreUtils::pairwise {
3088 no warnings qw(uninitialized);
3090 } @{$base}, @{$other};
3093 # We'll just be picking the 1st grouping in the hash, alphabetically
3096 _ProcessObjectCustomFieldUpdates(
3097 Prefix => GetCustomFieldInputNamePrefix(
3099 CustomField => $CustomFieldObj,
3100 Grouping => $groupings[0],
3103 CustomField => $CustomFieldObj,
3104 ARGS => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3112 sub _ParseObjectCustomFieldArgs {
3113 my $ARGSRef = shift || {};
3114 my %custom_fields_to_mod;
3116 foreach my $arg ( keys %$ARGSRef ) {
3118 # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3119 # you can use GetCustomFieldInputName to generate the complement input name
3120 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/;
3122 next if $1 eq 'RT::Transaction';# don't try to update transaction fields
3124 # For each of those objects, find out what custom fields we want to work with.
3125 # Class ID CF grouping command
3126 $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3129 return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3132 sub _ProcessObjectCustomFieldUpdates {
3134 my $cf = $args{'CustomField'};
3135 my $cf_type = $cf->Type || '';
3137 # Remove blank Values since the magic field will take care of this. Sometimes
3138 # the browser gives you a blank value which causes CFs to be processed twice
3139 if ( defined $args{'ARGS'}->{'Values'}
3140 && !length $args{'ARGS'}->{'Values'}
3141 && ($args{'ARGS'}->{'Values-Magic'}) )
3143 delete $args{'ARGS'}->{'Values'};
3147 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3149 # skip category argument
3150 next if $arg =~ /-Category$/;
3153 next if $arg eq 'Value-TimeUnits';
3155 # since http won't pass in a form element with a null value, we need
3157 if ( $arg =~ /-Magic$/ ) {
3159 # We don't care about the magic, if there's really a values element;
3160 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
3161 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3163 # "Empty" values does not mean anything for Image and Binary fields
3164 next if $cf_type =~ /^(?:Image|Binary)$/;
3167 $args{'ARGS'}->{'Values'} = undef;
3170 my @values = _NormalizeObjectCustomFieldValue(
3172 Param => $args{'Prefix'} . $arg,
3173 Value => $args{'ARGS'}->{$arg}
3176 # "Empty" values still don't mean anything for Image and Binary fields
3177 next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3179 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3180 foreach my $value (@values) {
3181 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3185 push( @results, $msg );
3187 } elsif ( $arg eq 'Upload' ) {
3188 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3189 push( @results, $msg );
3190 } elsif ( $arg eq 'DeleteValues' ) {
3191 foreach my $value (@values) {
3192 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3196 push( @results, $msg );
3198 } elsif ( $arg eq 'DeleteValueIds' ) {
3199 foreach my $value (@values) {
3200 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3204 push( @results, $msg );
3206 } elsif ( $arg eq 'Values' ) {
3207 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3210 foreach my $value (@values) {
3211 if ( my $entry = $cf_values->HasEntry($value) ) {
3212 $values_hash{ $entry->id } = 1;
3216 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3220 push( @results, $msg );
3221 $values_hash{$val} = 1 if $val;
3224 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3225 return @results if ( $cf->Type eq 'Date' && ! @values );
3227 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3228 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3230 $cf_values->RedoSearch;
3231 while ( my $cf_value = $cf_values->Next ) {
3232 next if $values_hash{ $cf_value->id };
3234 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3236 ValueId => $cf_value->id
3238 push( @results, $msg );
3243 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3244 $cf->Name, ref $args{'Object'},
3253 sub ProcessObjectCustomFieldUpdatesForCreate {
3256 ContextObject => undef,
3259 my $context = $args{'ContextObject'};
3261 my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3263 for my $class (keys %custom_fields) {
3264 # we're only interested in new objects, so only look at $id == 0
3265 for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3266 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3268 my $system_cf = RT::CustomField->new( RT->SystemUser );
3269 $system_cf->LoadById($cfid);
3270 if ($system_cf->ValidateContextObject($context)) {
3271 $cf->SetContextObject($context);
3274 sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3275 ref $context, $context->id, $system_cf->id
3280 $cf->LoadById($cfid);
3283 RT->Logger->warning("Couldn't load custom field #$cfid");
3287 my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3288 if (@groupings > 1) {
3289 # Check for consistency, in case of JS fail
3290 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3291 warn "CF $cfid submitted with multiple differing $key"
3292 if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3293 ne ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3296 # We'll just be picking the 1st grouping in the hash, alphabetically
3300 my $name_prefix = GetCustomFieldInputNamePrefix(
3302 Grouping => $groupings[0],
3304 while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3305 # Values-Magic doesn't matter on create; no previous values are being removed
3306 # Category is irrelevant for the actual value
3307 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3310 _NormalizeObjectCustomFieldValue(
3312 Param => $name_prefix . $arg,
3317 $parsed{"CustomField-$cfid"} = \@values if @values;
3321 return wantarray ? %parsed : \%parsed;
3324 sub _NormalizeObjectCustomFieldValue {
3329 my $cf_type = $args{CustomField}->Type;
3332 if ( ref $args{'Value'} eq 'ARRAY' ) {
3333 @values = @{ $args{'Value'} };
3334 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
3335 @values = ( $args{'Value'} );
3337 @values = split /\r*\n/, $args{'Value'}
3338 if defined $args{'Value'};
3340 @values = grep length, map {
3346 grep defined, @values;
3348 if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3349 @values = _UploadedFile( $args{'Param'} ) || ();
3355 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3357 Returns an array of results messages.
3361 sub ProcessTicketWatchers {
3369 my $Ticket = $args{'TicketObj'};
3370 my $ARGSRef = $args{'ARGSRef'};
3374 foreach my $key ( keys %$ARGSRef ) {
3376 # Delete deletable watchers
3377 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3378 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3382 push @results, $msg;
3385 # Delete watchers in the simple style demanded by the bulk manipulator
3386 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3387 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3388 Email => $ARGSRef->{$key},
3391 push @results, $msg;
3394 # Add new wathchers by email address
3395 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3396 and $key =~ /^WatcherTypeEmail(\d*)$/ )
3399 #They're in this order because otherwise $1 gets clobbered :/
3400 my ( $code, $msg ) = $Ticket->AddWatcher(
3401 Type => $ARGSRef->{$key},
3402 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3404 push @results, $msg;
3407 #Add requestors in the simple style demanded by the bulk manipulator
3408 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3409 my ( $code, $msg ) = $Ticket->AddWatcher(
3411 Email => $ARGSRef->{$key}
3413 push @results, $msg;
3416 # Add new watchers by owner
3417 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3418 my $principal_id = $1;
3419 my $form = $ARGSRef->{$key};
3420 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3421 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3423 my ( $code, $msg ) = $Ticket->AddWatcher(
3425 PrincipalId => $principal_id
3427 push @results, $msg;
3437 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3439 Returns an array of results messages.
3443 sub ProcessTicketDates {
3450 my $Ticket = $args{'TicketObj'};
3451 my $ARGSRef = $args{'ARGSRef'};
3456 my @date_fields = qw(
3464 #Run through each field in this list. update the value if apropriate
3465 foreach my $field (@date_fields) {
3466 next unless exists $ARGSRef->{ $field . '_Date' };
3467 next if $ARGSRef->{ $field . '_Date' } eq '';
3471 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3473 Format => 'unknown',
3474 Value => $ARGSRef->{ $field . '_Date' }
3477 my $obj = $field . "Obj";
3478 if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3479 my $method = "Set$field";
3480 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3481 push @results, "$msg";
3491 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3493 Returns an array of results messages.
3497 sub ProcessTicketLinks {
3505 my $Ticket = $args{'TicketObj'};
3506 my $TicketId = $args{'TicketId'} || $Ticket->Id;
3507 my $ARGSRef = $args{'ARGSRef'};
3509 my (@results) = ProcessRecordLinks(
3510 %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3513 #Merge if we need to
3514 my $input = $TicketId .'-MergeInto';
3515 if ( $ARGSRef->{ $input } ) {
3516 $ARGSRef->{ $input } =~ s/\s+//g;
3517 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3518 push @results, $msg;
3525 sub ProcessRecordLinks {
3533 my $Record = $args{'RecordObj'};
3534 my $RecordId = $args{'RecordId'} || $Record->Id;
3535 my $ARGSRef = $args{'ARGSRef'};
3539 # Delete links that are gone gone gone.
3540 foreach my $arg ( keys %$ARGSRef ) {
3541 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3546 my ( $val, $msg ) = $Record->DeleteLink(
3552 push @results, $msg;
3558 my @linktypes = qw( DependsOn MemberOf RefersTo );
3560 foreach my $linktype (@linktypes) {
3561 my $input = $RecordId .'-'. $linktype;
3562 if ( $ARGSRef->{ $input } ) {
3563 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3564 if ref $ARGSRef->{ $input };
3566 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3568 $luri =~ s/\s+$//; # Strip trailing whitespace
3569 my ( $val, $msg ) = $Record->AddLink(
3573 push @results, $msg;
3576 $input = $linktype .'-'. $RecordId;
3577 if ( $ARGSRef->{ $input } ) {
3578 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3579 if ref $ARGSRef->{ $input };
3581 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3583 my ( $val, $msg ) = $Record->AddLink(
3588 push @results, $msg;
3596 =head2 ProcessLinksForCreate
3598 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3601 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3602 C<LINKTYPE-new> into their appropriate directional link types. For example,
3603 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3604 C<DependedOnBy>. The incoming arg values are split on whitespace and
3605 normalized into arrayrefs before being returned.
3607 Primarily used by object creation pages for transforming incoming form inputs
3608 from F</Elements/EditLinks> into arguments appropriate for individual record
3611 Returns a hashref in scalar context and a hash in list context.
3615 sub ProcessLinksForCreate {
3619 foreach my $type ( keys %RT::Link::DIRMAP ) {
3620 for ([Base => "new-$type"], [Target => "$type-new"]) {
3621 my ($direction, $key) = @$_;
3622 next unless $args{ARGSRef}->{$key};
3623 $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3624 grep $_, split ' ', $args{ARGSRef}->{$key}
3628 return wantarray ? %links : \%links;
3631 =head2 ProcessTransactionSquelching
3633 Takes a hashref of the submitted form arguments, C<%ARGS>.
3635 Returns a hash of squelched addresses.
3639 sub ProcessTransactionSquelching {
3641 my %checked = map { $_ => 1 } grep { defined }
3642 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3643 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3645 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3649 sub ProcessRecordBulkCustomFields {
3650 my %args = (RecordObj => undef, ARGSRef => {}, @_);
3652 my $ARGSRef = $args{'ARGSRef'};
3657 foreach my $key ( keys %$ARGSRef ) {
3658 next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3659 my ($op, $cfid, $rest) = ($1, $2, $3);
3660 next if $rest =~ /-Category$/;
3662 my $res = $data{$cfid} ||= {};
3663 unless (keys %$res) {
3664 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3666 next unless $cf->Id;
3671 if ( $op eq 'Delete' && $rest eq 'AllValues' ) {
3672 $res->{'DeleteAll'} = $ARGSRef->{$key};
3676 my @values = _NormalizeObjectCustomFieldValue(
3677 CustomField => $res->{'cf'},
3678 Value => $ARGSRef->{$key},
3681 next unless @values;
3682 $res->{$op} = \@values;
3685 while ( my ($cfid, $data) = each %data ) {
3686 my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
3688 # just add one value for fields with single value
3689 if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
3690 next if $current_values->HasEntry($data->{Add}[-1]);
3692 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3694 Value => $data->{'Add'}[-1],
3696 push @results, $msg;
3700 if ( $data->{'DeleteAll'} ) {
3701 while ( my $value = $current_values->Next ) {
3702 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3704 ValueId => $value->id,
3706 push @results, $msg;
3709 foreach my $value ( @{ $data->{'Delete'} || [] } ) {
3710 my $entry = $current_values->HasEntry($value);
3713 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3715 ValueId => $entry->id,
3717 push @results, $msg;
3719 foreach my $value ( @{ $data->{'Add'} || [] } ) {
3720 next if $current_values->HasEntry($value);
3722 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3726 push @results, $msg;
3732 =head2 _UploadedFile ( $arg );
3734 Takes a CGI parameter name; if a file is uploaded under that name,
3735 return a hash reference suitable for AddCustomFieldValue's use:
3736 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3738 Returns C<undef> if no files were uploaded in the C<$arg> field.
3744 my $cgi_object = $m->cgi_object;
3745 my $fh = $cgi_object->upload($arg) or return undef;
3746 my $upload_info = $cgi_object->uploadInfo($fh);
3748 my $filename = "$fh";
3749 $filename =~ s#^.*[\\/]##;
3754 LargeContent => do { local $/; scalar <$fh> },
3755 ContentType => $upload_info->{'Content-Type'},
3759 sub GetColumnMapEntry {
3760 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3762 # deal with the simplest thing first
3763 if ( $args{'Map'}{ $args{'Name'} } ) {
3764 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3768 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3769 $subkey =~ s/^\{(.*)\}$/$1/;
3770 return undef unless $args{'Map'}->{$mainkey};
3771 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3772 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3774 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3779 sub ProcessColumnMapValue {
3781 my %args = ( Arguments => [], Escape => 1, @_ );
3784 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3785 my @tmp = $value->( @{ $args{'Arguments'} } );
3786 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3787 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3788 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3789 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3793 if ($args{'Escape'}) {
3794 $value = $m->interp->apply_escapes( $value, 'h' );
3795 $value =~ s/\n/<br>/g if defined $value;
3801 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3803 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3804 principal collections mapped from the categories given.
3808 sub GetPrincipalsMap {
3813 my $system = RT::Groups->new($session{'CurrentUser'});
3814 $system->LimitToSystemInternalGroups();
3815 $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3817 'System' => $system, # loc_left_pair
3822 my $groups = RT::Groups->new($session{'CurrentUser'});
3823 $groups->LimitToUserDefinedGroups();
3824 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3826 # Only show groups who have rights granted on this object
3827 $groups->WithGroupRight(
3830 IncludeSystemRights => 0,
3831 IncludeSubgroupMembers => 0,
3835 'User Groups' => $groups, # loc_left_pair
3840 my $roles = RT::Groups->new($session{'CurrentUser'});
3842 if ($object->isa("RT::CustomField")) {
3843 # If we're a custom field, show the global roles for our LookupType.
3844 my $class = $object->RecordClassFromLookupType;
3845 if ($class and $class->DOES("RT::Record::Role::Roles")) {
3846 $roles->LimitToRolesForObject(RT->System);
3849 FUNCTION => 'LOWER(?)',
3851 VALUE => [ map {lc $_} $class->Roles ],
3855 # No roles to show; so show nothing
3859 $roles->LimitToRolesForObject($object);
3863 $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3865 'Roles' => $roles, # loc_left_pair
3871 my $Users = RT->PrivilegedUsers->UserMembersObj();
3872 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3874 # Only show users who have rights granted on this object
3875 my $group_members = $Users->WhoHaveGroupRight(
3878 IncludeSystemRights => 0,
3879 IncludeSubgroupMembers => 0,
3882 # Limit to UserEquiv groups
3883 my $groups = $Users->Join(
3884 ALIAS1 => $group_members,
3885 FIELD1 => 'GroupId',
3889 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 );
3890 $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 );
3893 'Users' => $Users, # loc_left_pair
3901 =head2 _load_container_object ( $type, $id );
3903 Instantiate container object for saving searches.
3907 sub _load_container_object {
3908 my ( $obj_type, $obj_id ) = @_;
3909 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3912 =head2 _parse_saved_search ( $arg );
3914 Given a serialization string for saved search, and returns the
3915 container object and the search id.
3919 sub _parse_saved_search {
3921 return unless $spec;
3922 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3929 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3932 =head2 ScrubHTML content
3934 Removes unsafe and undesired HTML from the passed content
3940 my $Content = shift;
3941 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3943 $Content = '' if !defined($Content);
3944 return $SCRUBBER->scrub($Content);
3949 Returns a new L<HTML::Scrubber> object.
3951 If you need to be more lax about what HTML tags and attributes are allowed,
3952 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3955 package HTML::Mason::Commands;
3956 # Let tables through
3957 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3962 our @SCRUBBER_ALLOWED_TAGS = qw(
3963 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5
3964 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3967 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3968 # Match http, https, ftp, mailto and relative urls
3969 # XXX: we also scrub format strings with this module then allow simple config options
3970 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
3977 (?:(?:background-)?color: \s*
3978 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3979 \#[a-f0-9]{3,6} | # #fff or #ffffff
3980 [\w\-]+ # green, light-blue, etc.
3982 text-align: \s* \w+ |
3983 font-size: \s* [\w.\-]+ |
3984 font-family: \s* [\w\s"',.\-]+ |
3985 font-weight: \s* [\w\-]+ |
3987 border-style: \s* \w+ |
3988 border-color: \s* [#\w]+ |
3989 border-width: \s* [\s\w]+ |
3990 padding: \s* [\s\w]+ |
3991 margin: \s* [\s\w]+ |
3993 # MS Office styles, which are probably fine. If we don't, then any
3994 # associated styles in the same attribute get stripped.
3995 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3997 +$ # one or more of these allowed properties from here 'till sunset
3999 dir => qr/^(rtl|ltr)$/i,
4000 lang => qr/^\w+(-\w+)?$/,
4003 our %SCRUBBER_RULES = ();
4005 # If we're displaying images, let embedded ones through
4006 if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) {
4007 $SCRUBBER_RULES{'img'} = {
4013 push @src, qr/^cid:/i
4014 if RT->Config->Get('ShowTransactionImages');
4016 push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'}
4017 if RT->Config->Get('ShowRemoteImages');
4019 $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src;
4023 require HTML::Scrubber;
4024 my $scrubber = HTML::Scrubber->new();
4026 if (HTML::Gumbo->require) {
4027 no warnings 'redefine';
4028 my $orig = \&HTML::Scrubber::scrub;
4029 *HTML::Scrubber::scrub = sub {
4032 eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
4033 warn "HTML::Gumbo pre-parse failed: $@" if $@;
4034 return $orig->($self, @_);
4036 push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
4037 $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
4038 qw/colspan rowspan align valign cellspacing cellpadding border width height/;
4044 %SCRUBBER_ALLOWED_ATTRIBUTES,
4045 '*' => 0, # require attributes be explicitly allowed
4048 $scrubber->deny(qw[*]);
4049 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
4050 $scrubber->rules(%SCRUBBER_RULES);
4052 # Scrubbing comments is vital since IE conditional comments can contain
4053 # arbitrary HTML and we'd pass it right on through.
4054 $scrubber->comment(0);
4061 Redispatches to L<RT::Interface::Web/EncodeJSON>
4066 RT::Interface::Web::EncodeJSON(@_);
4071 return '' unless defined $value;
4072 $value =~ s/[^A-Za-z0-9_-]/_/g;
4076 sub GetCustomFieldInputName {
4077 RT::Interface::Web::GetCustomFieldInputName(@_);
4080 sub GetCustomFieldInputNamePrefix {
4081 RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
4084 package RT::Interface::Web;
4085 RT::Base->_ImportOverlays();