1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
47 # END BPS TAGGED BLOCK }}}
49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
51 ## This is a library of static subs to be used by the Mason web
64 package RT::Interface::Web;
66 use RT::SavedSearches;
68 use RT::Interface::Web::Menu;
69 use RT::Interface::Web::Session;
71 use List::MoreUtils qw();
74 =head2 SquishedCSS $style
80 my $style = shift or die "need name";
81 return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
82 require RT::Squish::CSS;
83 my $css = RT::Squish::CSS->new( Style => $style );
84 $SQUISHED_CSS{ $css->Style } = $css;
94 return $SQUISHED_JS if $SQUISHED_JS;
96 require RT::Squish::JS;
97 my $js = RT::Squish::JS->new();
104 Removes the cached CSS and JS entries, forcing them to be regenerated
114 =head2 EscapeUTF8 SCALARREF
116 does a css-busting but minimalist escaping of whatever html you're passing in.
122 return unless defined $$ref;
124 $$ref =~ s/&/&/g;
127 $$ref =~ s/\(/(/g;
128 $$ref =~ s/\)/)/g;
129 $$ref =~ s/"/"/g;
130 $$ref =~ s/'/'/g;
135 =head2 EscapeURI SCALARREF
137 Escapes URI component according to RFC2396
143 return unless defined $$ref;
146 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
149 =head2 EncodeJSON SCALAR
151 Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
152 value or a reference.
157 JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
160 sub _encode_surrogates {
161 my $uni = $_[0] - 0x10000;
162 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
167 return unless defined $$ref;
169 $$ref = "'" . join('',
171 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
172 $_ <= 255 ? sprintf("\\x%02X", $_) :
173 $_ <= 65535 ? sprintf("\\u%04X", $_) :
174 sprintf("\\u%X\\u%X", _encode_surrogates($_))
175 } unpack('U*', $$ref))
179 =head2 WebCanonicalizeInfo();
181 Different web servers set different environmental varibles. This
182 function must return something suitable for REMOTE_USER. By default,
183 just downcase $ENV{'REMOTE_USER'}
187 sub WebCanonicalizeInfo {
188 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
193 =head2 WebExternalAutoInfo($user);
195 Returns a hash of user attributes, used when WebExternalAuto is set.
199 sub WebExternalAutoInfo {
204 # default to making Privileged users, even if they specify
205 # some other default Attributes
206 if ( !$RT::AutoCreate
207 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
209 $user_info{'Privileged'} = 1;
212 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
214 # Populate fields with information from Unix /etc/passwd
216 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
217 $user_info{'Comments'} = $comments if defined $comments;
218 $user_info{'RealName'} = $realname if defined $realname;
219 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
221 # Populate fields with information from NT domain controller
224 # and return the wad of stuff
232 if (RT->Config->Get('DevelMode')) {
233 require Module::Refresh;
234 Module::Refresh->refresh;
237 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
239 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
241 # Roll back any dangling transactions from a previous failed connection
242 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
244 MaybeEnableSQLStatementLog();
246 # avoid reentrancy, as suggested by masonbook
247 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
249 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
250 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
255 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
256 PreprocessTimeUpdates($ARGS);
259 MaybeShowInstallModePage();
261 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
264 if ( _UserLoggedIn() ) {
265 # make user info up to date
266 $HTML::Mason::Commands::session{'CurrentUser'}
267 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
268 undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
271 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
274 # Process session-related callbacks before any auth attempts
275 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
277 MaybeRejectPrivateComponentRequest();
279 MaybeShowNoAuthPage($ARGS);
281 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
283 _ForceLogout() unless _UserLoggedIn();
285 # Process per-page authentication callbacks
286 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
288 if ( $ARGS->{'NotMobile'} ) {
289 $HTML::Mason::Commands::session{'NotMobile'} = 1;
292 unless ( _UserLoggedIn() ) {
295 # Authenticate if the user is trying to login via user/pass query args
296 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
299 my $m = $HTML::Mason::Commands::m;
301 # REST urls get a special 401 response
302 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
303 $HTML::Mason::Commands::r->content_type("text/plain");
304 $m->error_format("text");
305 $m->out("RT/$RT::VERSION 401 Credentials required\n");
306 $m->out("\n$msg\n") if $msg;
309 # Specially handle /index.html and /m/index.html so that we get a nicer URL
310 elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
311 my $mobile = $1 ? 1 : 0;
312 my $next = SetNextPage($ARGS);
313 $m->comp('/NoAuth/Login.html',
320 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
325 MaybeShowInterstitialCSRFPage($ARGS);
327 # now it applies not only to home page, but any dashboard that can be used as a workspace
328 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
329 if ( $ARGS->{'HomeRefreshInterval'} );
331 # Process per-page global callbacks
332 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
334 ShowRequestedPage($ARGS);
335 LogRecordedSQLStatements(RequestData => {
336 Path => $HTML::Mason::Commands::m->request_path,
339 # Process per-page final cleanup callbacks
340 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
342 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
343 unless $HTML::Mason::Commands::r->content_type
344 =~ qr<^(text|application)/(x-)?(css|javascript)>;
349 delete $HTML::Mason::Commands::session{'CurrentUser'};
353 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
361 =head2 LoginError ERROR
363 Pushes a login error into the Actions session store and returns the hash key.
369 my $key = Digest::MD5::md5_hex( rand(1024) );
370 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
371 $HTML::Mason::Commands::session{'i'}++;
375 =head2 SetNextPage ARGSRef [PATH]
377 Intuits and stashes the next page in the sesssion hash. If PATH is
378 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
385 my $next = $_[0] ? $_[0] : IntuitNextPage();
386 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
387 my $page = { url => $next };
389 # If an explicit URL was passed and we didn't IntuitNextPage, then
390 # IsPossibleCSRF below is almost certainly unrelated to the actual
391 # destination. Currently explicit next pages aren't used in RT, but the
393 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
394 # This isn't really CSRF, but the CSRF heuristics are useful for catching
395 # requests which may have unintended side-effects.
396 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
399 "Marking original destination as having side-effects before redirecting for login.\n"
401 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
403 $page->{'HasSideEffects'} = [$msg, @loc];
407 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
408 $HTML::Mason::Commands::session{'i'}++;
412 =head2 FetchNextPage HASHKEY
414 Returns the stashed next page hashref for the given hash.
419 my $hash = shift || "";
420 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
423 =head2 RemoveNextPage HASHKEY
425 Removes the stashed next page for the given hash and returns it.
430 my $hash = shift || "";
431 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
434 =head2 TangentForLogin ARGSRef [HASH]
436 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
437 the next page. Takes a hashref of request %ARGS as the first parameter.
438 Optionally takes all other parameters as a hash which is dumped into query
443 sub TangentForLogin {
445 my $hash = SetNextPage($ARGS);
446 my %query = (@_, next => $hash);
449 if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
451 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
452 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
456 =head2 TangentForLoginWithError ERROR
458 Localizes the passed error message, stashes it with L<LoginError> and then
459 calls L<TangentForLogin> with the appropriate results key.
463 sub TangentForLoginWithError {
465 my $key = LoginError(HTML::Mason::Commands::loc(@_));
466 TangentForLogin( $ARGS, results => $key );
469 =head2 IntuitNextPage
471 Attempt to figure out the path to which we should return the user after a
472 tangent. The current request URL is used, or failing that, the C<WebURL>
473 configuration variable.
480 # This includes any query parameters. Redirect will take care of making
481 # it an absolute URL.
482 if ($ENV{'REQUEST_URI'}) {
483 $req_uri = $ENV{'REQUEST_URI'};
485 # collapse multiple leading slashes so the first part doesn't look like
486 # a hostname of a schema-less URI
487 $req_uri =~ s{^/+}{/};
490 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
493 my $uri = URI->new($next);
495 # You get undef scheme with a relative uri like "/Search/Build.html"
496 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
497 $next = RT->Config->Get('WebURL');
500 # Make sure we're logging in to the same domain
501 # You can get an undef authority with a relative uri like "index.html"
502 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
503 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
504 $next = RT->Config->Get('WebURL');
510 =head2 MaybeShowInstallModePage
512 This function, called exclusively by RT's autohandler, dispatches
513 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
515 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
519 sub MaybeShowInstallModePage {
520 return unless RT->InstallMode;
522 my $m = $HTML::Mason::Commands::m;
523 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
525 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
526 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
533 =head2 MaybeShowNoAuthPage \%ARGS
535 This function, called exclusively by RT's autohandler, dispatches
536 a request to the page a user requested (but only if it matches the "noauth" regex.
538 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
542 sub MaybeShowNoAuthPage {
545 my $m = $HTML::Mason::Commands::m;
547 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
549 # Don't show the login page to logged in users
550 Redirect(RT->Config->Get('WebURL'))
551 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
553 # If it's a noauth file, don't ask for auth.
554 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
558 =head2 MaybeRejectPrivateComponentRequest
560 This function will reject calls to private components, like those under
561 C</Elements>. If the requested path is a private component then we will
562 abort with a C<403> error.
566 sub MaybeRejectPrivateComponentRequest {
567 my $m = $HTML::Mason::Commands::m;
568 my $path = $m->request_comp->path;
570 # We do not check for dhandler here, because requesting our dhandlers
571 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
577 _elements | # mobile UI
580 autohandler | # requesting this directly is suspicious
581 l (_unsafe)? ) # loc component
582 ( $ | / ) # trailing slash or end of path
584 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
587 warn "rejecting private component $path\n";
595 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
596 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
597 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
602 =head2 ShowRequestedPage \%ARGS
604 This function, called exclusively by RT's autohandler, dispatches
605 a request to the page a user requested (making sure that unpriviled users
606 can only see self-service pages.
610 sub ShowRequestedPage {
613 my $m = $HTML::Mason::Commands::m;
615 # Ensure that the cookie that we send is up-to-date, in case the
616 # session-id has been modified in any way
619 # precache all system level rights for the current user
620 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
622 # If the user isn't privileged, they can only see SelfService
623 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
625 # if the user is trying to access a ticket, redirect them
626 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
627 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
630 # otherwise, drop the user at the SelfService default page
631 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
632 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
635 # if user is in SelfService dir let him do anything
637 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
640 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
645 sub AttemptExternalAuth {
648 return unless ( RT->Config->Get('WebExternalAuth') );
650 my $user = $ARGS->{user};
651 my $m = $HTML::Mason::Commands::m;
653 # If RT is configured for external auth, let's go through and get REMOTE_USER
655 # do we actually have a REMOTE_USER equivlent?
656 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
657 my $orig_user = $user;
659 $user = RT::Interface::Web::WebCanonicalizeInfo();
660 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
662 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
663 my $NodeName = Win32::NodeName();
664 $user =~ s/^\Q$NodeName\E\\//i;
667 my $next = RemoveNextPage($ARGS->{'next'});
668 $next = $next->{'url'} if ref $next;
669 InstantiateNewSession() unless _UserLoggedIn;
670 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
671 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
673 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
675 # Create users on-the-fly
676 my $UserObj = RT::User->new(RT->SystemUser);
677 my ( $val, $msg ) = $UserObj->Create(
678 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
685 # now get user specific information, to better create our user.
686 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
688 # set the attributes that have been defined.
689 foreach my $attribute ( $UserObj->WritableAttributes ) {
691 Attribute => $attribute,
693 UserInfo => $new_user_info,
694 CallbackName => 'NewUser',
695 CallbackPage => '/autohandler'
697 my $method = "Set$attribute";
698 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
700 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
703 # we failed to successfully create the user. abort abort abort.
704 delete $HTML::Mason::Commands::session{'CurrentUser'};
706 if (RT->Config->Get('WebFallbackToInternalAuth')) {
707 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
714 if ( _UserLoggedIn() ) {
715 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
716 # It is possible that we did a redirect to the login page,
717 # if the external auth allows lack of auth through with no
718 # REMOTE_USER set, instead of forcing a "permission
719 # denied" message. Honor the $next.
720 Redirect($next) if $next;
721 # Unlike AttemptPasswordAuthentication below, we do not
722 # force a redirect to / if $next is not set -- otherwise,
723 # straight-up external auth would always redirect to /
724 # when you first hit it.
726 delete $HTML::Mason::Commands::session{'CurrentUser'};
729 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
730 TangentForLoginWithError($ARGS, 'You are not an authorized user');
733 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
734 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
735 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
736 TangentForLoginWithError($ARGS, 'You are not an authorized user');
740 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
741 # XXX: we must return AUTH_REQUIRED status or we fallback to
742 # internal auth here too.
743 delete $HTML::Mason::Commands::session{'CurrentUser'}
744 if defined $HTML::Mason::Commands::session{'CurrentUser'};
748 sub AttemptPasswordAuthentication {
750 return unless defined $ARGS->{user} && defined $ARGS->{pass};
752 my $user_obj = RT::CurrentUser->new();
753 $user_obj->Load( $ARGS->{user} );
755 my $m = $HTML::Mason::Commands::m;
757 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
758 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
759 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
760 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
763 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
765 # It's important to nab the next page from the session before we blow
767 my $next = RemoveNextPage($ARGS->{'next'});
768 $next = $next->{'url'} if ref $next;
770 InstantiateNewSession();
771 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
773 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
775 # Really the only time we don't want to redirect here is if we were
776 # passed user and pass as query params in the URL.
780 elsif ($ARGS->{'next'}) {
781 # Invalid hash, but still wants to go somewhere, take them to /
782 Redirect(RT->Config->Get('WebURL'));
785 return (1, HTML::Mason::Commands::loc('Logged in'));
789 =head2 LoadSessionFromCookie
791 Load or setup a session cookie for the current user.
795 sub _SessionCookieName {
796 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
797 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
801 sub LoadSessionFromCookie {
803 my %cookies = CGI::Cookie->fetch;
804 my $cookiename = _SessionCookieName();
805 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
806 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
807 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
808 InstantiateNewSession();
810 if ( int RT->Config->Get('AutoLogoff') ) {
811 my $now = int( time / 60 );
812 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
814 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
815 InstantiateNewSession();
818 # save session on each request when AutoLogoff is turned on
819 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
823 sub InstantiateNewSession {
824 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
825 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
829 sub SendSessionCookie {
830 my $cookie = CGI::Cookie->new(
831 -name => _SessionCookieName(),
832 -value => $HTML::Mason::Commands::session{_session_id},
833 -path => RT->Config->Get('WebPath'),
834 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
835 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
838 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
843 This routine ells the current user's browser to redirect to URL.
844 Additionally, it unties the user's currently active session, helping to avoid
845 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
846 a cached DBI statement handle twice at the same time.
851 my $redir_to = shift;
852 untie $HTML::Mason::Commands::session;
853 my $uri = URI->new($redir_to);
854 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
856 # Make relative URIs absolute from the server host and scheme
857 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
858 if (not defined $uri->host) {
859 $uri->host($server_uri->host);
860 $uri->port($server_uri->port);
863 # If the user is coming in via a non-canonical
864 # hostname, don't redirect them to the canonical host,
865 # it will just upset them (and invalidate their credentials)
866 # don't do this if $RT::CanonicalizeRedirectURLs is true
867 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
868 && $uri->host eq $server_uri->host
869 && $uri->port eq $server_uri->port )
871 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
872 $uri->scheme('https');
874 $uri->scheme('http');
877 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
878 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
879 $uri->port( $ENV{'SERVER_PORT'} );
882 # not sure why, but on some systems without this call mason doesn't
883 # set status to 302, but 200 instead and people see blank pages
884 $HTML::Mason::Commands::r->status(302);
886 # Perlbal expects a status message, but Mason's default redirect status
887 # doesn't provide one. See also rt.cpan.org #36689.
888 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
890 $HTML::Mason::Commands::m->abort;
893 =head2 CacheControlExpiresHeaders
895 set both Cache-Control and Expires http headers
899 sub CacheControlExpiresHeaders {
902 my $Visibility = 'private';
903 if ( ! defined $args{Time} ) {
905 } elsif ( $args{Time} eq 'no-cache' ) {
907 } elsif ( $args{Time} eq 'forever' ) {
908 $args{Time} = 30 * 24 * 60 * 60;
909 $Visibility = 'public';
912 my $CacheControl = $args{Time}
913 ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
916 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
918 my $expires = RT::Date->new(RT->SystemUser);
920 $expires->AddSeconds( $args{Time} ) if $args{Time};
922 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
925 =head2 StaticFileHeaders
927 Send the browser a few headers to try to get it to (somewhat agressively)
928 cache RT's static Javascript and CSS files.
930 This routine could really use _accurate_ heuristics. (XXX TODO)
934 sub StaticFileHeaders {
935 my $date = RT::Date->new(RT->SystemUser);
937 # remove any cookie headers -- if it is cached publicly, it
938 # shouldn't include anyone's cookie!
939 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
941 # Expire things in a month.
942 CacheControlExpiresHeaders( Time => 'forever' );
944 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
945 # request, but we don't handle it and generate full reply again
946 # Last modified at server start time
947 # $date->Set( Value => $^T );
948 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
951 =head2 ComponentPathIsSafe PATH
953 Takes C<PATH> and returns a boolean indicating that the user-specified partial
954 component path is safe.
956 Currently "safe" means that the path does not start with a dot (C<.>), does
957 not contain a slash-dot C</.>, and does not contain any nulls.
961 sub ComponentPathIsSafe {
964 return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
969 Takes a C<< Path => path >> and returns a boolean indicating that
970 the path is safely within RT's control or not. The path I<must> be
973 This function does not consult the filesystem at all; it is merely
974 a logical sanity checking of the path. This explicitly does not handle
975 symlinks; if you have symlinks in RT's webroot pointing outside of it,
976 then we assume you know what you are doing.
983 my $path = $args{Path};
985 # Get File::Spec to clean up extra /s, ./, etc
986 my $cleaned_up = File::Spec->canonpath($path);
988 if (!defined($cleaned_up)) {
989 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
993 # Forbid too many ..s. We can't just sum then check because
994 # "../foo/bar/baz" should be illegal even though it has more
995 # downdirs than updirs. So as soon as we get a negative score
996 # (which means "breaking out" of the top level) we reject the path.
998 my @components = split '/', $cleaned_up;
1000 for my $component (@components) {
1001 if ($component eq '..') {
1004 $RT::Logger->info("Rejecting unsafe path: $path");
1008 elsif ($component eq '.' || $component eq '') {
1009 # these two have no effect on $score
1019 =head2 SendStaticFile
1021 Takes a File => path and a Type => Content-type
1023 If Type isn't provided and File is an image, it will
1024 figure out a sane Content-type, otherwise it will
1025 send application/octet-stream
1027 Will set caching headers using StaticFileHeaders
1031 sub SendStaticFile {
1034 my $file = $args{File};
1035 my $type = $args{Type};
1036 my $relfile = $args{RelativeFile};
1038 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1039 $HTML::Mason::Commands::r->status(400);
1040 $HTML::Mason::Commands::m->abort;
1043 $self->StaticFileHeaders();
1046 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1048 $type =~ s/jpg/jpeg/gi;
1050 $type ||= "application/octet-stream";
1052 $HTML::Mason::Commands::r->content_type($type);
1053 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1057 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1058 $HTML::Mason::Commands::m->flush_buffer;
1069 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'}) {
1080 my $content = $args{Content};
1081 return '' unless $content;
1083 # Make the content have no 'weird' newlines in it
1084 $content =~ s/\r+\n/\n/g;
1086 my $return_content = $content;
1088 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1089 my $sigonly = $args{StripSignature};
1091 # massage content to easily detect if there's any real content
1092 $content =~ s/\s+//g; # yes! remove all the spaces
1094 # remove html version of spaces and newlines
1095 $content =~ s! !!g;
1096 $content =~ s!<br/?>!!g;
1099 # Filter empty content when type is text/html
1100 return '' if $html && $content !~ /\S/;
1102 # If we aren't supposed to strip the sig, just bail now.
1103 return $return_content unless $sigonly;
1105 # Find the signature
1106 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1109 # Check for plaintext sig
1110 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1112 # Check for html-formatted sig; we don't use EscapeUTF8 here
1113 # because we want to precisely match the escapting that FCKEditor
1115 $sig =~ s/&/&/g;
1118 $sig =~ s/"/"/g;
1119 $sig =~ s/'/'/g;
1120 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1123 return $return_content;
1129 # Later in the code we use
1130 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1131 # instead of $m->call_next to avoid problems with UTF8 keys in
1132 # arguments. Specifically, the call_next method pass through
1133 # original arguments, which are still the encoded bytes, not
1134 # characters. "{ base_comp => $m->request_comp }" is copied from
1135 # mason's source to get the same results as we get from call_next
1136 # method; this feature is not documented.
1139 # if they've passed multiple values, they'll be an array. if they've
1140 # passed just one, a scalar whatever they are, mark them as utf8
1143 ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
1144 : ( $type eq 'ARRAY' )
1145 ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
1146 : ( $type eq 'HASH' )
1147 ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
1152 sub PreprocessTimeUpdates {
1155 # This code canonicalizes time inputs in hours into minutes
1156 foreach my $field ( keys %$ARGS ) {
1157 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1159 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1160 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1161 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1162 $ARGS->{$local} *= 60;
1164 delete $ARGS->{$field};
1169 sub MaybeEnableSQLStatementLog {
1171 my $log_sql_statements = RT->Config->Get('StatementLog');
1173 if ($log_sql_statements) {
1174 $RT::Handle->ClearSQLStatementLog;
1175 $RT::Handle->LogSQLStatements(1);
1180 sub LogRecordedSQLStatements {
1183 my $log_sql_statements = RT->Config->Get('StatementLog');
1185 return unless ($log_sql_statements);
1187 my @log = $RT::Handle->SQLStatementLog;
1188 $RT::Handle->ClearSQLStatementLog;
1190 $RT::Handle->AddRequestToHistory({
1191 %{ $args{RequestData} },
1195 for my $stmt (@log) {
1196 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1206 level => $log_sql_statements,
1208 . sprintf( "%.6f", $duration )
1210 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1216 my $_has_validated_web_config = 0;
1217 sub ValidateWebConfig {
1220 # do this once per server instance, not once per request
1221 return if $_has_validated_web_config;
1222 $_has_validated_web_config = 1;
1224 my $port = $ENV{SERVER_PORT};
1225 my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1226 || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
1227 ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1229 if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1230 $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
1231 ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1232 ."otherwise your internal links may be broken.");
1235 if ( $host ne RT->Config->Get('WebDomain') ) {
1236 $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
1237 ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1238 ."otherwise your internal links may be broken.");
1241 return; #next warning flooding our logs, doesn't seem applicable to our use
1242 # (SCRIPT_NAME is the full path, WebPath is just the beginning)
1243 #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
1245 # Unfortunately, there is no reliable way to get the _path_ that was
1246 # requested at the proxy level; simply disable this warning if we're
1247 # proxied and there's a mismatch.
1248 my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1249 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1250 $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
1251 ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1252 ."otherwise your internal links may be broken.");
1256 sub ComponentRoots {
1258 my %args = ( Names => 0, @_ );
1260 if (defined $HTML::Mason::Commands::m) {
1261 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1264 [ local => $RT::MasonLocalComponentRoot ],
1265 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1266 [ standard => $RT::MasonComponentRoot ]
1269 @roots = map { $_->[1] } @roots unless $args{Names};
1273 our %is_whitelisted_component = (
1274 # The RSS feed embeds an auth token in the path, but query
1275 # information for the search. Because it's a straight-up read, in
1276 # addition to embedding its own auth, it's fine.
1277 '/NoAuth/rss/dhandler' => 1,
1279 # While these can be used for denial-of-service against RT
1280 # (construct a very inefficient query and trick lots of users into
1281 # running them against RT) it's incredibly useful to be able to link
1282 # to a search result (or chart) or bookmark a result page.
1283 '/Search/Results.html' => 1,
1284 '/Search/Simple.html' => 1,
1285 '/m/tickets/search' => 1,
1286 '/Search/Chart.html' => 1,
1288 # This page takes Attachment and Transaction argument to figure
1289 # out what to show, but it's read only and will deny information if you
1290 # don't have ShowOutgoingEmail.
1291 '/Ticket/ShowEmailRecord.html' => 1,
1294 # Components which are blacklisted from automatic, argument-based whitelisting.
1295 # These pages are not idempotent when called with just an id.
1296 our %is_blacklisted_component = (
1297 # Takes only id and toggles bookmark state
1298 '/Helpers/Toggle/TicketBookmark' => 1,
1301 sub IsCompCSRFWhitelisted {
1305 return 1 if $is_whitelisted_component{$comp};
1307 my %args = %{ $ARGS };
1309 # If the user specifies a *correct* user and pass then they are
1310 # golden. This acts on the presumption that external forms may
1311 # hardcode a username and password -- if a malicious attacker knew
1312 # both already, CSRF is the least of your problems.
1313 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1314 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1315 my $user_obj = RT::CurrentUser->new();
1316 $user_obj->Load($args{user});
1317 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1323 # Some pages aren't idempotent even with safe args like id; blacklist
1324 # them from the automatic whitelisting below.
1325 return 0 if $is_blacklisted_component{$comp};
1327 # Eliminate arguments that do not indicate an effectful request.
1328 # For example, "id" is acceptable because that is how RT retrieves a
1332 # If they have a results= from MaybeRedirectForResults, that's also fine.
1333 delete $args{results};
1335 # The homepage refresh, which uses the Refresh header, doesn't send
1336 # a referer in most browsers; whitelist the one parameter it reloads
1337 # with, HomeRefreshInterval, which is safe
1338 delete $args{HomeRefreshInterval};
1340 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1341 # in the session related to which interface you get.
1342 delete $args{NotMobile};
1344 # If there are no arguments, then it's likely to be an idempotent
1345 # request, which are not susceptible to CSRF
1351 sub IsRefererCSRFWhitelisted {
1352 my $referer = _NormalizeHost(shift);
1353 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1354 $base_url = $base_url->host_port;
1357 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1358 push @$configs,$config;
1360 my $host_port = $referer->host_port;
1361 if ($config =~ /\*/) {
1362 # Turn a literal * into a domain component or partial component match.
1363 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1364 my $regex = join "[a-zA-Z0-9\-]*",
1365 map { quotemeta($_) }
1366 split /\*/, $config;
1368 return 1 if $host_port =~ /^$regex$/i;
1370 return 1 if $host_port eq $config;
1374 return (0,$referer,$configs);
1377 =head3 _NormalizeHost
1379 Takes a URI and creates a URI object that's been normalized
1380 to handle common problems such as localhost vs 127.0.0.1
1384 sub _NormalizeHost {
1386 $s = "http://$s" unless $s =~ /^http/i;
1387 my $uri= URI->new($s);
1388 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1394 sub IsPossibleCSRF {
1397 # If first request on this session is to a REST endpoint, then
1398 # whitelist the REST endpoints -- and explicitly deny non-REST
1399 # endpoints. We do this because using a REST cookie in a browser
1400 # would open the user to CSRF attacks to the REST endpoints.
1401 my $path = $HTML::Mason::Commands::r->path_info;
1402 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1403 unless defined $HTML::Mason::Commands::session{'REST'};
1405 if ($HTML::Mason::Commands::session{'REST'}) {
1406 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1408 This login session belongs to a REST client, and cannot be used to
1409 access non-REST interfaces of RT for security reasons.
1411 my $details = <<EOT;
1412 Please log out and back in to obtain a session for normal browsing. If
1413 you understand the security implications, disabling RT's CSRF protection
1414 will remove this restriction.
1417 HTML::Mason::Commands::Abort( $why, Details => $details );
1420 return 0 if IsCompCSRFWhitelisted(
1421 $HTML::Mason::Commands::m->request_comp->path,
1425 # if there is no Referer header then assume the worst
1427 "your browser did not supply a Referrer header", # loc
1428 ) if !$ENV{HTTP_REFERER};
1430 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1431 return 0 if $whitelisted;
1433 if ( @$configs > 1 ) {
1435 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1436 $browser->host_port,
1438 join(', ', @$configs) );
1442 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1443 $browser->host_port,
1447 sub ExpandCSRFToken {
1450 my $token = delete $ARGS->{CSRF_Token};
1451 return unless $token;
1453 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1454 return unless $data;
1455 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1457 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1458 return unless $user->ValidateAuthString( $data->{auth}, $token );
1460 %{$ARGS} = %{$data->{args}};
1461 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1463 # We explicitly stored file attachments with the request, but not in
1464 # the session yet, as that would itself be an attack. Put them into
1465 # the session now, so they'll be visible.
1466 if ($data->{attach}) {
1467 my $filename = $data->{attach}{filename};
1468 my $mime = $data->{attach}{mime};
1469 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1476 sub StoreRequestToken {
1479 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1480 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1482 auth => $user->GenerateAuthString( $token ),
1483 path => $HTML::Mason::Commands::r->path_info,
1486 if ($ARGS->{Attach}) {
1487 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1488 my $file_path = delete $ARGS->{'Attach'};
1490 # This needs to be decoded because the value is a reference;
1491 # hence it was not decoded along with all of the standard
1492 # arguments in DecodeARGS
1494 filename => Encode::decode("UTF-8", "$file_path"),
1495 mime => $attachment,
1499 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1500 $HTML::Mason::Commands::session{'i'}++;
1504 sub MaybeShowInterstitialCSRFPage {
1507 return unless RT->Config->Get('RestrictReferrer');
1509 # Deal with the form token provided by the interstitial, which lets
1510 # browsers which never set referer headers still use RT, if
1511 # painfully. This blows values into ARGS
1512 return if ExpandCSRFToken($ARGS);
1514 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1515 return if !$is_csrf;
1517 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1519 my $token = StoreRequestToken($ARGS);
1520 $HTML::Mason::Commands::m->comp(
1522 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1523 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1526 # Calls abort, never gets here
1529 our @POTENTIAL_PAGE_ACTIONS = (
1530 qr'/Ticket/Create.html' => "create a ticket", # loc
1531 qr'/Ticket/' => "update a ticket", # loc
1532 qr'/Admin/' => "modify RT's configuration", # loc
1533 qr'/Approval/' => "update an approval", # loc
1534 qr'/Articles/' => "update an article", # loc
1535 qr'/Dashboards/' => "modify a dashboard", # loc
1536 qr'/m/ticket/' => "update a ticket", # loc
1537 qr'Prefs' => "modify your preferences", # loc
1538 qr'/Search/' => "modify or access a search", # loc
1539 qr'/SelfService/Create' => "create a ticket", # loc
1540 qr'/SelfService/' => "update a ticket", # loc
1543 sub PotentialPageAction {
1545 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1546 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1547 return HTML::Mason::Commands::loc($result)
1548 if $page =~ $pattern;
1553 package HTML::Mason::Commands;
1555 use vars qw/$r $m %session/;
1558 return $HTML::Mason::Commands::m->notes('menu');
1562 return $HTML::Mason::Commands::m->notes('page-menu');
1566 return $HTML::Mason::Commands::m->notes('page-widgets');
1573 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1574 with whatever it's called with. If there is no $session{'CurrentUser'},
1575 it creates a temporary user, so we have something to get a localisation handle
1582 if ( $session{'CurrentUser'}
1583 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1585 return ( $session{'CurrentUser'}->loc(@_) );
1588 RT::CurrentUser->new();
1592 return ( $u->loc(@_) );
1595 # pathetic case -- SystemUser is gone.
1602 =head2 loc_fuzzy STRING
1604 loc_fuzzy is for handling localizations of messages that may already
1605 contain interpolated variables, typically returned from libraries
1606 outside RT's control. It takes the message string and extracts the
1607 variable array automatically by matching against the candidate entries
1608 inside the lexicon file.
1615 if ( $session{'CurrentUser'}
1616 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1618 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1620 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1621 return ( $u->loc_fuzzy($msg) );
1626 # Error - calls Error and aborts
1631 if ( $session{'ErrorDocument'}
1632 && $session{'ErrorDocumentType'} )
1634 $r->content_type( $session{'ErrorDocumentType'} );
1635 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1638 $m->comp( "/Elements/Error", Why => $why, %args );
1643 sub MaybeRedirectForResults {
1645 Path => $HTML::Mason::Commands::m->request_comp->path,
1652 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1653 return unless $has_actions || $args{'Force'};
1655 my %arguments = %{ $args{'Arguments'} };
1657 if ( $has_actions ) {
1658 my $key = Digest::MD5::md5_hex( rand(1024) );
1659 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1661 $arguments{'results'} = $key;
1664 $args{'Path'} =~ s!^/+!!;
1665 my $url = RT->Config->Get('WebURL') . $args{Path};
1667 if ( keys %arguments ) {
1668 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1670 if ( $args{'Anchor'} ) {
1671 $url .= "#". $args{'Anchor'};
1673 return RT::Interface::Web::Redirect($url);
1676 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1678 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1679 redirect to the approvals display page, preserving any arguments.
1681 C<Path>s matching C<Whitelist> are let through.
1683 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1687 sub MaybeRedirectToApproval {
1689 Path => $HTML::Mason::Commands::m->request_comp->path,
1695 return unless $ENV{REQUEST_METHOD} eq 'GET';
1697 my $id = $args{ARGSRef}->{id};
1700 and RT->Config->Get('ForceApprovalsView')
1701 and not $args{Path} =~ /$args{Whitelist}/)
1703 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1706 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1707 MaybeRedirectForResults(
1708 Path => "/Approvals/Display.html",
1710 Anchor => $args{ARGSRef}->{Anchor},
1711 Arguments => $args{ARGSRef},
1717 =head2 CreateTicket ARGS
1719 Create a new ticket, using Mason's %ARGS. returns @results.
1728 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1730 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1731 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1732 Abort('Queue not found');
1735 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1736 Abort('You have no permission to create tickets in that queue.');
1740 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1741 $due = RT::Date->new( $session{'CurrentUser'} );
1742 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1745 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1746 $starts = RT::Date->new( $session{'CurrentUser'} );
1747 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1750 my $sigless = RT::Interface::Web::StripContent(
1751 Content => $ARGS{Content},
1752 ContentType => $ARGS{ContentType},
1753 StripSignature => 1,
1754 CurrentUser => $session{'CurrentUser'},
1757 my $MIMEObj = MakeMIMEEntity(
1758 Subject => $ARGS{'Subject'},
1759 From => $ARGS{'From'},
1762 Type => $ARGS{'ContentType'},
1763 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1766 if ( $ARGS{'Attachments'} ) {
1767 my $rv = $MIMEObj->make_multipart;
1768 $RT::Logger->error("Couldn't make multipart message")
1769 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1771 foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
1773 $RT::Logger->error("Couldn't add empty attachemnt");
1776 $MIMEObj->add_part($_);
1780 for my $argument (qw(Encrypt Sign)) {
1781 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1785 Type => $ARGS{'Type'} || 'ticket',
1786 Queue => $ARGS{'Queue'},
1787 Owner => $ARGS{'Owner'},
1790 Requestor => $ARGS{'Requestors'},
1792 AdminCc => $ARGS{'AdminCc'},
1793 InitialPriority => $ARGS{'InitialPriority'},
1794 FinalPriority => $ARGS{'FinalPriority'},
1795 TimeLeft => $ARGS{'TimeLeft'},
1796 TimeEstimated => $ARGS{'TimeEstimated'},
1797 TimeWorked => $ARGS{'TimeWorked'},
1798 Subject => $ARGS{'Subject'},
1799 Status => $ARGS{'Status'},
1800 Due => $due ? $due->ISO : undef,
1801 Starts => $starts ? $starts->ISO : undef,
1806 foreach my $type (qw(Requestor Cc AdminCc)) {
1807 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1808 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1810 $create_args{TransSquelchMailTo} = \@txn_squelch
1813 if ( $ARGS{'AttachTickets'} ) {
1814 require RT::Action::SendEmail;
1815 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1816 ref $ARGS{'AttachTickets'}
1817 ? @{ $ARGS{'AttachTickets'} }
1818 : ( $ARGS{'AttachTickets'} ) );
1821 foreach my $arg ( keys %ARGS ) {
1822 next if $arg =~ /-(?:Magic|Category)$/;
1824 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1825 $create_args{$arg} = $ARGS{$arg};
1828 # Object-RT::Ticket--CustomField-3-Values
1829 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1832 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1833 $cf->SetContextObject( $Queue );
1835 unless ( $cf->id ) {
1836 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1840 if ( $arg =~ /-Upload$/ ) {
1841 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1845 my $type = $cf->Type;
1848 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1849 @values = @{ $ARGS{$arg} };
1850 } elsif ( $type =~ /text/i ) {
1851 @values = ( $ARGS{$arg} );
1853 no warnings 'uninitialized';
1854 @values = split /\r*\n/, $ARGS{$arg};
1856 @values = grep length, map {
1862 grep defined, @values;
1864 $create_args{"CustomField-$cfid"} = \@values;
1868 # turn new link lists into arrays, and pass in the proper arguments
1870 'new-DependsOn' => 'DependsOn',
1871 'DependsOn-new' => 'DependedOnBy',
1872 'new-MemberOf' => 'Parents',
1873 'MemberOf-new' => 'Children',
1874 'new-RefersTo' => 'RefersTo',
1875 'RefersTo-new' => 'ReferredToBy',
1877 foreach my $key ( keys %map ) {
1878 next unless $ARGS{$key};
1879 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1883 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1888 push( @Actions, split( "\n", $ErrMsg ) );
1889 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1890 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1892 return ( $Ticket, @Actions );
1898 =head2 LoadTicket id
1900 Takes a ticket id as its only variable. if it's handed an array, it takes
1903 Returns an RT::Ticket object as the current user.
1910 if ( ref($id) eq "ARRAY" ) {
1915 Abort("No ticket specified");
1918 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1920 unless ( $Ticket->id ) {
1921 Abort("Could not load ticket $id");
1928 =head2 ProcessUpdateMessage
1930 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1932 Don't write message if it only contains current user's signature and
1933 SkipSignatureOnly argument is true. Function anyway adds attachments
1934 and updates time worked field even if skips message. The default value
1939 # change from stock: if txn custom fields are set but there's no content
1940 # or attachment, create a Touch txn instead of doing nothing
1942 sub ProcessUpdateMessage {
1947 SkipSignatureOnly => 1,
1951 if ( $args{ARGSRef}->{'UpdateAttachments'}
1952 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1954 delete $args{ARGSRef}->{'UpdateAttachments'};
1957 # Strip the signature
1958 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1959 Content => $args{ARGSRef}->{UpdateContent},
1960 ContentType => $args{ARGSRef}->{UpdateContentType},
1961 StripSignature => $args{SkipSignatureOnly},
1962 CurrentUser => $args{'TicketObj'}->CurrentUser,
1965 my %txn_customfields;
1967 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1968 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1969 next if $key =~ /(TimeUnits|Magic)$/;
1970 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1974 # If, after stripping the signature, we have no message, create a
1975 # Touch transaction if necessary
1976 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1977 and not length $args{ARGSRef}->{'UpdateContent'} )
1979 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1980 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1981 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1984 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1985 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1986 my ( $Transaction, $Description, $Object ) =
1987 $args{TicketObj}->Touch(
1988 CustomFields => \%txn_customfields,
1989 TimeTaken => $timetaken
1991 return $Description;
1996 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1997 $args{ARGSRef}->{'UpdateSubject'} = undef;
2000 my $Message = MakeMIMEEntity(
2001 Subject => $args{ARGSRef}->{'UpdateSubject'},
2002 Body => $args{ARGSRef}->{'UpdateContent'},
2003 Type => $args{ARGSRef}->{'UpdateContentType'},
2004 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2007 $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2008 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2010 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2011 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2012 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2014 $old_txn = $args{TicketObj}->Transactions->First();
2017 if ( my $msg = $old_txn->Message->First ) {
2018 RT::Interface::Email::SetInReplyTo(
2019 Message => $Message,
2024 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2025 $Message->make_multipart;
2026 $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
2027 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2030 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2031 require RT::Action::SendEmail;
2032 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2033 ref $args{ARGSRef}->{'AttachTickets'}
2034 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2035 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2038 my %message_args = (
2039 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2040 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2041 MIMEObj => $Message,
2042 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2043 CustomFields => \%txn_customfields,
2046 _ProcessUpdateMessageRecipients(
2047 MessageArgs => \%message_args,
2052 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2053 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2054 push( @results, $Description );
2055 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2056 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2057 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2058 push( @results, $Description );
2059 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2062 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2067 sub _ProcessUpdateMessageRecipients {
2071 MessageArgs => undef,
2075 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2076 my $cc = $args{ARGSRef}->{'UpdateCc'};
2078 my $message_args = $args{MessageArgs};
2080 $message_args->{CcMessageTo} = $cc;
2081 $message_args->{BccMessageTo} = $bcc;
2084 foreach my $type (qw(Cc AdminCc)) {
2085 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2086 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2087 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2088 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2091 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2092 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2093 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2096 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2097 $message_args->{SquelchMailTo} = \@txn_squelch
2100 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2101 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2102 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2104 my $var = ucfirst($1) . 'MessageTo';
2106 if ( $message_args->{$var} ) {
2107 $message_args->{$var} .= ", $value";
2109 $message_args->{$var} = $value;
2115 sub ProcessAttachments {
2121 my $ARGSRef = $args{ARGSRef} || {};
2122 # deal with deleting uploaded attachments
2123 foreach my $key ( keys %$ARGSRef ) {
2124 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2125 delete $session{'Attachments'}{$1};
2127 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2130 # store the uploaded attachment in session
2131 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2133 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2135 # This needs to be decoded because the value is a reference;
2136 # hence it was not decoded along with all of the standard
2137 # arguments in DecodeARGS
2138 my $file_path = Encode::decode("UTF-8", "$ARGSRef->{'Attach'}");
2139 $session{'Attachments'} =
2140 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2143 # delete temporary storage entry to make WebUI clean
2144 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2146 delete $session{'Attachments'};
2151 =head2 MakeMIMEEntity PARAMHASH
2153 Takes a paramhash Subject, Body and AttachmentFieldName.
2155 Also takes Form, Cc and Type as optional paramhash keys.
2157 Returns a MIME::Entity.
2161 sub MakeMIMEEntity {
2163 #TODO document what else this takes.
2169 AttachmentFieldName => undef,
2174 my $Message = MIME::Entity->build(
2175 Type => 'multipart/mixed',
2176 "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2177 "X-RT-Interface" => $args{Interface},
2178 map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2179 grep defined $args{$_}, qw(Subject From Cc)
2182 if ( defined $args{'Body'} && length $args{'Body'} ) {
2184 # Make the update content have no 'weird' newlines in it
2185 $args{'Body'} =~ s/\r\n/\n/gs;
2188 Type => $args{'Type'} || 'text/plain',
2190 Data => Encode::encode( "UTF-8", $args{'Body'} ),
2194 if ( $args{'AttachmentFieldName'} ) {
2196 my $cgi_object = $m->cgi_object;
2197 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2198 if ( defined $filehandle && length $filehandle ) {
2200 my ( @content, $buffer );
2201 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2202 push @content, $buffer;
2205 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2207 my $filename = Encode::decode("UTF-8","$filehandle");
2208 $filename =~ s{^.*[\\/]}{};
2211 Type => $uploadinfo->{'Content-Type'},
2212 Filename => Encode::encode("UTF-8",$filename),
2213 Data => \@content, # Bytes, as read directly from the file, above
2215 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2216 $Message->head->set( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2219 # Attachment parts really shouldn't get a Message-ID or "interface"
2220 $Message->head->delete('Message-ID');
2221 $Message->head->delete('X-RT-Interface');
2225 $Message->make_singlepart;
2227 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2235 =head2 ParseDateToISO
2237 Takes a date in an arbitrary format.
2238 Returns an ISO date and time in GMT
2242 sub ParseDateToISO {
2245 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2247 Format => 'unknown',
2250 return ( $date_obj->ISO );
2255 sub ProcessACLChanges {
2256 my $ARGSref = shift;
2260 foreach my $arg ( keys %$ARGSref ) {
2261 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2263 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2266 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2267 @rights = @{ $ARGSref->{$arg} };
2269 @rights = $ARGSref->{$arg};
2271 @rights = grep $_, @rights;
2272 next unless @rights;
2274 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2275 $principal->Load($principal_id);
2278 if ( $object_type eq 'RT::System' ) {
2280 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2281 $obj = $object_type->new( $session{'CurrentUser'} );
2282 $obj->Load($object_id);
2283 unless ( $obj->id ) {
2284 $RT::Logger->error("couldn't load $object_type #$object_id");
2288 $RT::Logger->error("object type '$object_type' is incorrect");
2289 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2293 foreach my $right (@rights) {
2294 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2295 push( @results, $msg );
2305 ProcessACLs expects values from a series of checkboxes that describe the full
2306 set of rights a principal should have on an object.
2308 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2309 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2310 listing the rights the principal should have, and ProcessACLs will modify the
2311 current rights to match. Additionally, the previously unused CheckACL input
2312 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2313 rights are removed from a principal and as such no SetRights input is
2319 my $ARGSref = shift;
2320 my (%state, @results);
2322 my $CheckACL = $ARGSref->{'CheckACL'};
2323 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2325 # Check if we want to grant rights to a previously rights-less user
2326 for my $type (qw(user group)) {
2327 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2330 unless ($principal->PrincipalId) {
2331 push @results, loc("Couldn't load the specified principal");
2335 my $principal_id = $principal->PrincipalId;
2337 # Turn our addprincipal rights spec into a real one
2338 for my $arg (keys %$ARGSref) {
2339 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2341 my $tuple = "$principal_id-$1";
2342 my $key = "SetRights-$tuple";
2344 # If we have it already, that's odd, but merge them
2345 if (grep { $_ eq $tuple } @check) {
2346 $ARGSref->{$key} = [
2347 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2348 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2351 $ARGSref->{$key} = $ARGSref->{$arg};
2352 push @check, $tuple;
2357 # Build our rights state for each Principal-Object tuple
2358 foreach my $arg ( keys %$ARGSref ) {
2359 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2362 my $value = $ARGSref->{$arg};
2363 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2364 next unless @rights;
2366 $state{$tuple} = { map { $_ => 1 } @rights };
2369 foreach my $tuple (List::MoreUtils::uniq @check) {
2370 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2372 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2374 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2375 $principal->Load($principal_id);
2378 if ( $object_type eq 'RT::System' ) {
2380 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2381 $obj = $object_type->new( $session{'CurrentUser'} );
2382 $obj->Load($object_id);
2383 unless ( $obj->id ) {
2384 $RT::Logger->error("couldn't load $object_type #$object_id");
2388 $RT::Logger->error("object type '$object_type' is incorrect");
2389 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2393 my $acls = RT::ACL->new($session{'CurrentUser'});
2394 $acls->LimitToObject( $obj );
2395 $acls->LimitToPrincipal( Id => $principal_id );
2397 while ( my $ace = $acls->Next ) {
2398 my $right = $ace->RightName;
2400 # Has right and should have right
2401 next if delete $state{$tuple}->{$right};
2403 # Has right and shouldn't have right
2404 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2405 push @results, $msg;
2408 # For everything left, they don't have the right but they should
2409 for my $right (keys %{ $state{$tuple} || {} }) {
2410 delete $state{$tuple}->{$right};
2411 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2412 push @results, $msg;
2415 # Check our state for leftovers
2416 if ( keys %{ $state{$tuple} || {} } ) {
2417 my $missed = join '|', %{$state{$tuple} || {}};
2419 "Uh-oh, it looks like we somehow missed a right in "
2420 ."ProcessACLs. Here's what was leftover: $missed"
2428 =head2 _ParseACLNewPrincipal
2430 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2431 for the presence of rights being added on a principal of the specified type,
2432 and returns undef if no new principal is being granted rights. Otherwise loads
2433 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2434 may not be successfully loaded, and you should check C<->id> yourself.
2438 sub _ParseACLNewPrincipal {
2439 my $ARGSref = shift;
2440 my $type = lc shift;
2441 my $key = "AddPrincipalForRights-$type";
2443 return unless $ARGSref->{$key};
2446 if ( $type eq 'user' ) {
2447 $principal = RT::User->new( $session{'CurrentUser'} );
2448 $principal->LoadByCol( Name => $ARGSref->{$key} );
2450 elsif ( $type eq 'group' ) {
2451 $principal = RT::Group->new( $session{'CurrentUser'} );
2452 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2458 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2460 @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.
2462 Returns an array of success/failure messages
2466 sub UpdateRecordObject {
2469 AttributesRef => undef,
2471 AttributePrefix => undef,
2475 my $Object = $args{'Object'};
2476 my @results = $Object->Update(
2477 AttributesRef => $args{'AttributesRef'},
2478 ARGSRef => $args{'ARGSRef'},
2479 AttributePrefix => $args{'AttributePrefix'},
2487 sub ProcessCustomFieldUpdates {
2489 CustomFieldObj => undef,
2494 my $Object = $args{'CustomFieldObj'};
2495 my $ARGSRef = $args{'ARGSRef'};
2497 my @attribs = qw(Name Type Description Queue SortOrder);
2498 my @results = UpdateRecordObject(
2499 AttributesRef => \@attribs,
2504 my $prefix = "CustomField-" . $Object->Id;
2505 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2506 my ( $addval, $addmsg ) = $Object->AddValue(
2507 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2508 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2509 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2511 push( @results, $addmsg );
2515 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2516 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2517 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2519 foreach my $id (@delete_values) {
2520 next unless defined $id;
2521 my ( $err, $msg ) = $Object->DeleteValue($id);
2522 push( @results, $msg );
2525 my $vals = $Object->Values();
2526 while ( my $cfv = $vals->Next() ) {
2527 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2528 if ( $cfv->SortOrder != $so ) {
2529 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2530 push( @results, $msg );
2540 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2542 Returns an array of results messages.
2546 sub ProcessTicketBasics {
2554 my $TicketObj = $args{'TicketObj'};
2555 my $ARGSRef = $args{'ARGSRef'};
2557 my $OrigOwner = $TicketObj->Owner;
2572 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2573 for my $field (qw(Queue Owner)) {
2574 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2575 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2576 my $temp = $class->new(RT->SystemUser);
2577 $temp->Load( $ARGSRef->{$field} );
2579 $ARGSRef->{$field} = $temp->id;
2584 # Status isn't a field that can be set to a null value.
2585 # RT core complains if you try
2586 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2588 my @results = UpdateRecordObject(
2589 AttributesRef => \@attribs,
2590 Object => $TicketObj,
2591 ARGSRef => $ARGSRef,
2594 # We special case owner changing, so we can use ForceOwnerChange
2595 if ( $ARGSRef->{'Owner'}
2596 && $ARGSRef->{'Owner'} !~ /\D/
2597 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2599 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2600 $ChownType = "Force";
2606 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2607 push( @results, $msg );
2615 sub ProcessTicketReminders {
2622 my $Ticket = $args{'TicketObj'};
2623 my $args = $args{'ARGSRef'};
2626 my $reminder_collection = $Ticket->Reminders->Collection;
2628 if ( $args->{'update-reminders'} ) {
2629 while ( my $reminder = $reminder_collection->Next ) {
2630 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2631 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2632 my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
2633 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2636 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2637 my ($status, $msg) = $Ticket->Reminders->Open($reminder);
2638 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2641 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2642 my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2643 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2646 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2647 my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2648 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2651 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2652 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2654 Format => 'unknown',
2655 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2657 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2658 my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
2659 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2665 if ( $args->{'NewReminder-Subject'} ) {
2666 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2668 Format => 'unknown',
2669 Value => $args->{'NewReminder-Due'}
2671 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2672 Subject => $args->{'NewReminder-Subject'},
2673 Owner => $args->{'NewReminder-Owner'},
2674 Due => $due_obj->ISO
2677 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2680 push @results, $msg;
2686 sub ProcessTicketCustomFieldUpdates {
2688 $args{'Object'} = delete $args{'TicketObj'};
2689 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2691 # Build up a list of objects that we want to work with
2692 my %custom_fields_to_mod;
2693 foreach my $arg ( keys %$ARGSRef ) {
2694 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2695 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2696 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2697 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2698 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2699 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2703 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2706 sub ProcessObjectCustomFieldUpdates {
2708 my $ARGSRef = $args{'ARGSRef'};
2711 # Build up a list of objects that we want to work with
2712 my %custom_fields_to_mod;
2713 foreach my $arg ( keys %$ARGSRef ) {
2715 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2716 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2718 # For each of those objects, find out what custom fields we want to work with.
2719 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2722 # For each of those objects
2723 foreach my $class ( keys %custom_fields_to_mod ) {
2724 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2725 my $Object = $args{'Object'};
2726 $Object = $class->new( $session{'CurrentUser'} )
2727 unless $Object && ref $Object eq $class;
2729 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2730 unless ( $Object->id ) {
2731 $RT::Logger->warning("Couldn't load object $class #$id");
2735 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2736 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2737 $CustomFieldObj->SetContextObject($Object);
2738 $CustomFieldObj->LoadById($cf);
2739 unless ( $CustomFieldObj->id ) {
2740 $RT::Logger->warning("Couldn't load custom field #$cf");
2744 _ProcessObjectCustomFieldUpdates(
2745 Prefix => "Object-$class-$id-CustomField-$cf-",
2747 CustomField => $CustomFieldObj,
2748 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2756 sub _ProcessObjectCustomFieldUpdates {
2758 my $cf = $args{'CustomField'};
2759 my $cf_type = $cf->Type || '';
2761 # Remove blank Values since the magic field will take care of this. Sometimes
2762 # the browser gives you a blank value which causes CFs to be processed twice
2763 if ( defined $args{'ARGS'}->{'Values'}
2764 && !length $args{'ARGS'}->{'Values'}
2765 && $args{'ARGS'}->{'Values-Magic'} )
2767 delete $args{'ARGS'}->{'Values'};
2771 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2773 # skip category argument
2774 next if $arg eq 'Category';
2777 next if $arg eq 'Value-TimeUnits';
2779 # since http won't pass in a form element with a null value, we need
2781 if ( $arg eq 'Values-Magic' ) {
2783 # We don't care about the magic, if there's really a values element;
2784 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2785 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2787 # "Empty" values does not mean anything for Image and Binary fields
2788 next if $cf_type =~ /^(?:Image|Binary)$/;
2791 $args{'ARGS'}->{'Values'} = undef;
2795 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2796 @values = @{ $args{'ARGS'}->{$arg} };
2797 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2798 @values = ( $args{'ARGS'}->{$arg} );
2800 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2801 if defined $args{'ARGS'}->{$arg};
2803 @values = grep length, map {
2809 grep defined, @values;
2811 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2812 foreach my $value (@values) {
2813 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2817 push( @results, $msg );
2819 } elsif ( $arg eq 'Upload' ) {
2820 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2821 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2822 push( @results, $msg );
2823 } elsif ( $arg eq 'DeleteValues' ) {
2824 foreach my $value (@values) {
2825 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2829 push( @results, $msg );
2831 } elsif ( $arg eq 'DeleteValueIds' ) {
2832 foreach my $value (@values) {
2833 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2837 push( @results, $msg );
2839 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2840 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2843 foreach my $value (@values) {
2844 if ( my $entry = $cf_values->HasEntry($value) ) {
2845 $values_hash{ $entry->id } = 1;
2849 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2853 push( @results, $msg );
2854 $values_hash{$val} = 1 if $val;
2857 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2858 return @results if ( $cf->Type eq 'Date' && ! @values );
2860 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2861 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2863 $cf_values->RedoSearch;
2864 while ( my $cf_value = $cf_values->Next ) {
2865 next if $values_hash{ $cf_value->id };
2867 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2869 ValueId => $cf_value->id
2871 push( @results, $msg );
2873 } elsif ( $arg eq 'Values' ) {
2874 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2876 # keep everything up to the point of difference, delete the rest
2878 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2879 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2888 # now add/replace extra things, if any
2889 foreach my $value (@values) {
2890 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2894 push( @results, $msg );
2899 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2900 $cf->Name, ref $args{'Object'},
2910 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2912 Returns an array of results messages.
2916 sub ProcessTicketWatchers {
2924 my $Ticket = $args{'TicketObj'};
2925 my $ARGSRef = $args{'ARGSRef'};
2929 foreach my $key ( keys %$ARGSRef ) {
2931 # Delete deletable watchers
2932 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2933 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2937 push @results, $msg;
2940 # Delete watchers in the simple style demanded by the bulk manipulator
2941 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2942 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2943 Email => $ARGSRef->{$key},
2946 push @results, $msg;
2949 # Add new wathchers by email address
2950 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2951 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2954 #They're in this order because otherwise $1 gets clobbered :/
2955 my ( $code, $msg ) = $Ticket->AddWatcher(
2956 Type => $ARGSRef->{$key},
2957 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2959 push @results, $msg;
2962 #Add requestors in the simple style demanded by the bulk manipulator
2963 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2964 my ( $code, $msg ) = $Ticket->AddWatcher(
2966 Email => $ARGSRef->{$key}
2968 push @results, $msg;
2971 # Add new watchers by owner
2972 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2973 my $principal_id = $1;
2974 my $form = $ARGSRef->{$key};
2975 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2976 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2978 my ( $code, $msg ) = $Ticket->AddWatcher(
2980 PrincipalId => $principal_id
2982 push @results, $msg;
2992 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2994 Returns an array of results messages.
2998 sub ProcessTicketDates {
3005 my $Ticket = $args{'TicketObj'};
3006 my $ARGSRef = $args{'ARGSRef'};
3011 my @date_fields = qw(
3020 #Run through each field in this list. update the value if apropriate
3021 foreach my $field (@date_fields) {
3022 next unless exists $ARGSRef->{ $field . '_Date' };
3023 next if $ARGSRef->{ $field . '_Date' } eq '';
3027 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3029 Format => 'unknown',
3030 Value => $ARGSRef->{ $field . '_Date' }
3033 my $obj = $field . "Obj";
3034 if ( ( defined $DateObj->Unix )
3035 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3037 my $method = "Set$field";
3038 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3039 push @results, "$msg";
3049 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3051 Returns an array of results messages.
3055 sub ProcessTicketLinks {
3062 my $Ticket = $args{'TicketObj'};
3063 my $ARGSRef = $args{'ARGSRef'};
3065 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3067 #Merge if we need to
3068 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3069 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3070 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3071 push @results, $msg;
3078 sub ProcessRecordLinks {
3085 my $Record = $args{'RecordObj'};
3086 my $ARGSRef = $args{'ARGSRef'};
3090 # Delete links that are gone gone gone.
3091 foreach my $arg ( keys %$ARGSRef ) {
3092 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3097 my ( $val, $msg ) = $Record->DeleteLink(
3103 push @results, $msg;
3109 my @linktypes = qw( DependsOn MemberOf RefersTo );
3111 foreach my $linktype (@linktypes) {
3112 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3113 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3114 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3116 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3118 $luri =~ s/\s+$//; # Strip trailing whitespace
3119 my ( $val, $msg ) = $Record->AddLink(
3123 push @results, $msg;
3126 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3127 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3128 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3130 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3132 my ( $val, $msg ) = $Record->AddLink(
3137 push @results, $msg;
3145 =head2 ProcessTransactionSquelching
3147 Takes a hashref of the submitted form arguments, C<%ARGS>.
3149 Returns a hash of squelched addresses.
3153 sub ProcessTransactionSquelching {
3155 my %checked = map { $_ => 1 } grep { defined }
3156 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3157 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3159 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3163 =head2 _UploadedFile ( $arg );
3165 Takes a CGI parameter name; if a file is uploaded under that name,
3166 return a hash reference suitable for AddCustomFieldValue's use:
3167 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3169 Returns C<undef> if no files were uploaded in the C<$arg> field.
3175 my $cgi_object = $m->cgi_object;
3176 my $fh = $cgi_object->upload($arg) or return undef;
3177 my $upload_info = $cgi_object->uploadInfo($fh);
3179 my $filename = "$fh";
3180 $filename =~ s#^.*[\\/]##;
3185 LargeContent => do { local $/; scalar <$fh> },
3186 ContentType => $upload_info->{'Content-Type'},
3190 sub GetColumnMapEntry {
3191 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3193 # deal with the simplest thing first
3194 if ( $args{'Map'}{ $args{'Name'} } ) {
3195 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3199 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3200 $subkey =~ s/^\{(.*)\}$/$1/;
3201 return undef unless $args{'Map'}->{$mainkey};
3202 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3203 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3205 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3210 sub ProcessColumnMapValue {
3212 my %args = ( Arguments => [], Escape => 1, @_ );
3215 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3216 my @tmp = $value->( @{ $args{'Arguments'} } );
3217 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3218 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3219 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3220 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3225 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3229 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3231 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3232 principal collections mapped from the categories given.
3236 sub GetPrincipalsMap {
3241 my $system = RT::Groups->new($session{'CurrentUser'});
3242 $system->LimitToSystemInternalGroups();
3243 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3245 'System' => $system, # loc_left_pair
3250 my $groups = RT::Groups->new($session{'CurrentUser'});
3251 $groups->LimitToUserDefinedGroups();
3252 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3254 # Only show groups who have rights granted on this object
3255 $groups->WithGroupRight(
3258 IncludeSystemRights => 0,
3259 IncludeSubgroupMembers => 0,
3263 'User Groups' => $groups, # loc_left_pair
3268 my $roles = RT::Groups->new($session{'CurrentUser'});
3270 if ($object->isa('RT::System')) {
3271 $roles->LimitToRolesForSystem();
3273 elsif ($object->isa('RT::Queue')) {
3274 $roles->LimitToRolesForQueue($object->Id);
3277 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3280 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3282 'Roles' => $roles, # loc_left_pair
3287 my $Users = RT->PrivilegedUsers->UserMembersObj();
3288 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3290 # Only show users who have rights granted on this object
3291 my $group_members = $Users->WhoHaveGroupRight(
3294 IncludeSystemRights => 0,
3295 IncludeSubgroupMembers => 0,
3298 # Limit to UserEquiv groups
3299 my $groups = $Users->NewAlias('Groups');
3303 ALIAS2 => $group_members,
3306 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3307 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3311 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3314 'Users' => $Users, # loc_left_pair
3322 =head2 _load_container_object ( $type, $id );
3324 Instantiate container object for saving searches.
3328 sub _load_container_object {
3329 my ( $obj_type, $obj_id ) = @_;
3330 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3333 =head2 _parse_saved_search ( $arg );
3335 Given a serialization string for saved search, and returns the
3336 container object and the search id.
3340 sub _parse_saved_search {
3342 return unless $spec;
3343 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3350 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3353 =head2 ScrubHTML content
3355 Removes unsafe and undesired HTML from the passed content
3361 my $Content = shift;
3362 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3364 $Content = '' if !defined($Content);
3365 return $SCRUBBER->scrub($Content);
3370 Returns a new L<HTML::Scrubber> object.
3372 If you need to be more lax about what HTML tags and attributes are allowed,
3373 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3376 package HTML::Mason::Commands;
3377 # Let tables through
3378 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3383 our @SCRUBBER_ALLOWED_TAGS = qw(
3384 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3385 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3388 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3389 # Match http, https, ftp, mailto and relative urls
3390 # XXX: we also scrub format strings with this module then allow simple config options
3391 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3397 (?:(?:background-)?color: \s*
3398 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3399 \#[a-f0-9]{3,6} | # #fff or #ffffff
3400 [\w\-]+ # green, light-blue, etc.
3402 text-align: \s* \w+ |
3403 font-size: \s* [\w.\-]+ |
3404 font-family: \s* [\w\s"',.\-]+ |
3405 font-weight: \s* [\w\-]+ |
3407 # MS Office styles, which are probably fine. If we don't, then any
3408 # associated styles in the same attribute get stripped.
3409 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3411 +$ # one or more of these allowed properties from here 'till sunset
3413 dir => qr/^(rtl|ltr)$/i,
3414 lang => qr/^\w+(-\w+)?$/,
3417 our %SCRUBBER_RULES = ();
3420 require HTML::Scrubber;
3421 my $scrubber = HTML::Scrubber->new();
3425 %SCRUBBER_ALLOWED_ATTRIBUTES,
3426 '*' => 0, # require attributes be explicitly allowed
3429 $scrubber->deny(qw[*]);
3430 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3431 $scrubber->rules(%SCRUBBER_RULES);
3433 # Scrubbing comments is vital since IE conditional comments can contain
3434 # arbitrary HTML and we'd pass it right on through.
3435 $scrubber->comment(0);
3442 Redispatches to L<RT::Interface::Web/EncodeJSON>
3447 RT::Interface::Web::EncodeJSON(@_);
3450 package RT::Interface::Web;
3451 RT::Base->_ImportOverlays();