1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
47 # END BPS TAGGED BLOCK }}}
49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
51 ## This is a library of static subs to be used by the Mason web
64 package RT::Interface::Web;
66 use RT::SavedSearches;
68 use RT::Interface::Web::Menu;
69 use RT::Interface::Web::Session;
72 use List::MoreUtils qw();
75 =head2 SquishedCSS $style
81 my $style = shift or die "need name";
82 return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
83 require RT::Squish::CSS;
84 my $css = RT::Squish::CSS->new( Style => $style );
85 $SQUISHED_CSS{ $css->Style } = $css;
95 return $SQUISHED_JS if $SQUISHED_JS;
97 require RT::Squish::JS;
98 my $js = RT::Squish::JS->new();
105 Removes the cached CSS and JS entries, forcing them to be regenerated
115 =head2 EscapeUTF8 SCALARREF
117 does a css-busting but minimalist escaping of whatever html you're passing in.
123 return unless defined $$ref;
125 $$ref =~ s/&/&/g;
128 $$ref =~ s/\(/(/g;
129 $$ref =~ s/\)/)/g;
130 $$ref =~ s/"/"/g;
131 $$ref =~ s/'/'/g;
136 =head2 EscapeURI SCALARREF
138 Escapes URI component according to RFC2396
144 return unless defined $$ref;
147 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
150 =head2 EncodeJSON SCALAR
152 Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
153 value or a reference.
158 JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
161 sub _encode_surrogates {
162 my $uni = $_[0] - 0x10000;
163 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
168 return unless defined $$ref;
170 $$ref = "'" . join('',
172 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
173 $_ <= 255 ? sprintf("\\x%02X", $_) :
174 $_ <= 65535 ? sprintf("\\u%04X", $_) :
175 sprintf("\\u%X\\u%X", _encode_surrogates($_))
176 } unpack('U*', $$ref))
180 =head2 WebCanonicalizeInfo();
182 Different web servers set different environmental varibles. This
183 function must return something suitable for REMOTE_USER. By default,
184 just downcase $ENV{'REMOTE_USER'}
188 sub WebCanonicalizeInfo {
189 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
194 =head2 WebExternalAutoInfo($user);
196 Returns a hash of user attributes, used when WebExternalAuto is set.
200 sub WebExternalAutoInfo {
205 # default to making Privileged users, even if they specify
206 # some other default Attributes
207 if ( !$RT::AutoCreate
208 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
210 $user_info{'Privileged'} = 1;
213 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
215 # Populate fields with information from Unix /etc/passwd
217 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
218 $user_info{'Comments'} = $comments if defined $comments;
219 $user_info{'RealName'} = $realname if defined $realname;
220 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
222 # Populate fields with information from NT domain controller
225 # and return the wad of stuff
233 if (RT->Config->Get('DevelMode')) {
234 require Module::Refresh;
235 Module::Refresh->refresh;
238 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
240 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
242 # Roll back any dangling transactions from a previous failed connection
243 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
245 MaybeEnableSQLStatementLog();
247 # avoid reentrancy, as suggested by masonbook
248 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
250 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
251 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
256 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
257 PreprocessTimeUpdates($ARGS);
260 MaybeShowInstallModePage();
262 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
265 if ( _UserLoggedIn() ) {
266 # make user info up to date
267 $HTML::Mason::Commands::session{'CurrentUser'}
268 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
269 undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
272 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
275 # Process session-related callbacks before any auth attempts
276 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
278 MaybeRejectPrivateComponentRequest();
280 MaybeShowNoAuthPage($ARGS);
282 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
284 _ForceLogout() unless _UserLoggedIn();
286 # Process per-page authentication callbacks
287 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
289 if ( $ARGS->{'NotMobile'} ) {
290 $HTML::Mason::Commands::session{'NotMobile'} = 1;
293 unless ( _UserLoggedIn() ) {
296 # Authenticate if the user is trying to login via user/pass query args
297 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
300 my $m = $HTML::Mason::Commands::m;
302 # REST urls get a special 401 response
303 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
304 $HTML::Mason::Commands::r->content_type("text/plain");
305 $m->error_format("text");
306 $m->out("RT/$RT::VERSION 401 Credentials required\n");
307 $m->out("\n$msg\n") if $msg;
310 # Specially handle /index.html and /m/index.html so that we get a nicer URL
311 elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
312 my $mobile = $1 ? 1 : 0;
313 my $next = SetNextPage($ARGS);
314 $m->comp('/NoAuth/Login.html',
321 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
326 MaybeShowInterstitialCSRFPage($ARGS);
328 # now it applies not only to home page, but any dashboard that can be used as a workspace
329 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
330 if ( $ARGS->{'HomeRefreshInterval'} );
332 # Process per-page global callbacks
333 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
335 ShowRequestedPage($ARGS);
336 LogRecordedSQLStatements(RequestData => {
337 Path => $HTML::Mason::Commands::m->request_path,
340 # Process per-page final cleanup callbacks
341 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
343 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
344 unless $HTML::Mason::Commands::r->content_type
345 =~ qr<^(text|application)/(x-)?(css|javascript)>;
350 delete $HTML::Mason::Commands::session{'CurrentUser'};
354 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
362 =head2 LoginError ERROR
364 Pushes a login error into the Actions session store and returns the hash key.
370 my $key = Digest::MD5::md5_hex( rand(1024) );
371 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
372 $HTML::Mason::Commands::session{'i'}++;
376 =head2 SetNextPage ARGSRef [PATH]
378 Intuits and stashes the next page in the sesssion hash. If PATH is
379 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
386 my $next = $_[0] ? $_[0] : IntuitNextPage();
387 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
388 my $page = { url => $next };
390 # If an explicit URL was passed and we didn't IntuitNextPage, then
391 # IsPossibleCSRF below is almost certainly unrelated to the actual
392 # destination. Currently explicit next pages aren't used in RT, but the
394 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
395 # This isn't really CSRF, but the CSRF heuristics are useful for catching
396 # requests which may have unintended side-effects.
397 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
400 "Marking original destination as having side-effects before redirecting for login.\n"
402 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
404 $page->{'HasSideEffects'} = [$msg, @loc];
408 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
409 $HTML::Mason::Commands::session{'i'}++;
413 =head2 FetchNextPage HASHKEY
415 Returns the stashed next page hashref for the given hash.
420 my $hash = shift || "";
421 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
424 =head2 RemoveNextPage HASHKEY
426 Removes the stashed next page for the given hash and returns it.
431 my $hash = shift || "";
432 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
435 =head2 TangentForLogin ARGSRef [HASH]
437 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
438 the next page. Takes a hashref of request %ARGS as the first parameter.
439 Optionally takes all other parameters as a hash which is dumped into query
444 sub TangentForLogin {
446 my $hash = SetNextPage($ARGS);
447 my %query = (@_, next => $hash);
450 if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
452 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
453 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
457 =head2 TangentForLoginWithError ERROR
459 Localizes the passed error message, stashes it with L<LoginError> and then
460 calls L<TangentForLogin> with the appropriate results key.
464 sub TangentForLoginWithError {
466 my $key = LoginError(HTML::Mason::Commands::loc(@_));
467 TangentForLogin( $ARGS, results => $key );
470 =head2 IntuitNextPage
472 Attempt to figure out the path to which we should return the user after a
473 tangent. The current request URL is used, or failing that, the C<WebURL>
474 configuration variable.
481 # This includes any query parameters. Redirect will take care of making
482 # it an absolute URL.
483 if ($ENV{'REQUEST_URI'}) {
484 $req_uri = $ENV{'REQUEST_URI'};
486 # collapse multiple leading slashes so the first part doesn't look like
487 # a hostname of a schema-less URI
488 $req_uri =~ s{^/+}{/};
491 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
494 my $uri = URI->new($next);
496 # You get undef scheme with a relative uri like "/Search/Build.html"
497 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
498 $next = RT->Config->Get('WebURL');
501 # Make sure we're logging in to the same domain
502 # You can get an undef authority with a relative uri like "index.html"
503 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
504 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
505 $next = RT->Config->Get('WebURL');
511 =head2 MaybeShowInstallModePage
513 This function, called exclusively by RT's autohandler, dispatches
514 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
516 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
520 sub MaybeShowInstallModePage {
521 return unless RT->InstallMode;
523 my $m = $HTML::Mason::Commands::m;
524 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
526 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
527 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
534 =head2 MaybeShowNoAuthPage \%ARGS
536 This function, called exclusively by RT's autohandler, dispatches
537 a request to the page a user requested (but only if it matches the "noauth" regex.
539 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
543 sub MaybeShowNoAuthPage {
546 my $m = $HTML::Mason::Commands::m;
548 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
550 # Don't show the login page to logged in users
551 Redirect(RT->Config->Get('WebURL'))
552 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
554 # If it's a noauth file, don't ask for auth.
555 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
559 =head2 MaybeRejectPrivateComponentRequest
561 This function will reject calls to private components, like those under
562 C</Elements>. If the requested path is a private component then we will
563 abort with a C<403> error.
567 sub MaybeRejectPrivateComponentRequest {
568 my $m = $HTML::Mason::Commands::m;
569 my $path = $m->request_comp->path;
571 # We do not check for dhandler here, because requesting our dhandlers
572 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
578 _elements | # mobile UI
581 autohandler | # requesting this directly is suspicious
582 l (_unsafe)? ) # loc component
583 ( $ | / ) # trailing slash or end of path
585 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
588 warn "rejecting private component $path\n";
596 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
597 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
598 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
603 =head2 ShowRequestedPage \%ARGS
605 This function, called exclusively by RT's autohandler, dispatches
606 a request to the page a user requested (making sure that unpriviled users
607 can only see self-service pages.
611 sub ShowRequestedPage {
614 my $m = $HTML::Mason::Commands::m;
616 # Ensure that the cookie that we send is up-to-date, in case the
617 # session-id has been modified in any way
620 # precache all system level rights for the current user
621 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
623 # If the user isn't privileged, they can only see SelfService
624 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
626 # if the user is trying to access a ticket, redirect them
627 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
628 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
631 # otherwise, drop the user at the SelfService default page
632 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
633 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
636 # if user is in SelfService dir let him do anything
638 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
641 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
646 sub AttemptExternalAuth {
649 return unless ( RT->Config->Get('WebExternalAuth') );
651 my $user = $ARGS->{user};
652 my $m = $HTML::Mason::Commands::m;
654 # If RT is configured for external auth, let's go through and get REMOTE_USER
656 # do we actually have a REMOTE_USER equivlent?
657 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
658 my $orig_user = $user;
660 $user = RT::Interface::Web::WebCanonicalizeInfo();
661 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
663 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
664 my $NodeName = Win32::NodeName();
665 $user =~ s/^\Q$NodeName\E\\//i;
668 my $next = RemoveNextPage($ARGS->{'next'});
669 $next = $next->{'url'} if ref $next;
670 InstantiateNewSession() unless _UserLoggedIn;
671 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
672 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
674 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
676 # Create users on-the-fly
677 my $UserObj = RT::User->new(RT->SystemUser);
678 my ( $val, $msg ) = $UserObj->Create(
679 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
686 # now get user specific information, to better create our user.
687 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
689 # set the attributes that have been defined.
690 foreach my $attribute ( $UserObj->WritableAttributes ) {
692 Attribute => $attribute,
694 UserInfo => $new_user_info,
695 CallbackName => 'NewUser',
696 CallbackPage => '/autohandler'
698 my $method = "Set$attribute";
699 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
701 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
704 # we failed to successfully create the user. abort abort abort.
705 delete $HTML::Mason::Commands::session{'CurrentUser'};
707 if (RT->Config->Get('WebFallbackToInternalAuth')) {
708 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
715 if ( _UserLoggedIn() ) {
716 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
717 # It is possible that we did a redirect to the login page,
718 # if the external auth allows lack of auth through with no
719 # REMOTE_USER set, instead of forcing a "permission
720 # denied" message. Honor the $next.
721 Redirect($next) if $next;
722 # Unlike AttemptPasswordAuthentication below, we do not
723 # force a redirect to / if $next is not set -- otherwise,
724 # straight-up external auth would always redirect to /
725 # when you first hit it.
727 delete $HTML::Mason::Commands::session{'CurrentUser'};
730 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
731 TangentForLoginWithError($ARGS, 'You are not an authorized user');
734 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
735 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
736 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
737 TangentForLoginWithError($ARGS, 'You are not an authorized user');
741 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
742 # XXX: we must return AUTH_REQUIRED status or we fallback to
743 # internal auth here too.
744 delete $HTML::Mason::Commands::session{'CurrentUser'}
745 if defined $HTML::Mason::Commands::session{'CurrentUser'};
749 sub AttemptPasswordAuthentication {
751 return unless defined $ARGS->{user} && defined $ARGS->{pass};
753 my $user_obj = RT::CurrentUser->new();
754 $user_obj->Load( $ARGS->{user} );
756 my $m = $HTML::Mason::Commands::m;
758 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
759 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
760 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
761 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
764 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
766 # It's important to nab the next page from the session before we blow
768 my $next = RemoveNextPage($ARGS->{'next'});
769 $next = $next->{'url'} if ref $next;
771 InstantiateNewSession();
772 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
774 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
776 # Really the only time we don't want to redirect here is if we were
777 # passed user and pass as query params in the URL.
781 elsif ($ARGS->{'next'}) {
782 # Invalid hash, but still wants to go somewhere, take them to /
783 Redirect(RT->Config->Get('WebURL'));
786 return (1, HTML::Mason::Commands::loc('Logged in'));
790 =head2 LoadSessionFromCookie
792 Load or setup a session cookie for the current user.
796 sub _SessionCookieName {
797 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
798 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
802 sub LoadSessionFromCookie {
804 my %cookies = CGI::Cookie->fetch;
805 my $cookiename = _SessionCookieName();
806 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
807 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
808 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
809 InstantiateNewSession();
811 if ( int RT->Config->Get('AutoLogoff') ) {
812 my $now = int( time / 60 );
813 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
815 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
816 InstantiateNewSession();
819 # save session on each request when AutoLogoff is turned on
820 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
824 sub InstantiateNewSession {
825 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
826 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
830 sub SendSessionCookie {
831 my $cookie = CGI::Cookie->new(
832 -name => _SessionCookieName(),
833 -value => $HTML::Mason::Commands::session{_session_id},
834 -path => RT->Config->Get('WebPath'),
835 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
836 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
839 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
844 This routine ells the current user's browser to redirect to URL.
845 Additionally, it unties the user's currently active session, helping to avoid
846 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
847 a cached DBI statement handle twice at the same time.
852 my $redir_to = shift;
853 untie $HTML::Mason::Commands::session;
854 my $uri = URI->new($redir_to);
855 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
857 # Make relative URIs absolute from the server host and scheme
858 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
859 if (not defined $uri->host) {
860 $uri->host($server_uri->host);
861 $uri->port($server_uri->port);
864 # If the user is coming in via a non-canonical
865 # hostname, don't redirect them to the canonical host,
866 # it will just upset them (and invalidate their credentials)
867 # don't do this if $RT::CanonicalizeRedirectURLs is true
868 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
869 && $uri->host eq $server_uri->host
870 && $uri->port eq $server_uri->port )
872 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
873 $uri->scheme('https');
875 $uri->scheme('http');
878 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
879 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
880 $uri->port( $ENV{'SERVER_PORT'} );
883 # not sure why, but on some systems without this call mason doesn't
884 # set status to 302, but 200 instead and people see blank pages
885 $HTML::Mason::Commands::r->status(302);
887 # Perlbal expects a status message, but Mason's default redirect status
888 # doesn't provide one. See also rt.cpan.org #36689.
889 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
891 $HTML::Mason::Commands::m->abort;
894 =head2 CacheControlExpiresHeaders
896 set both Cache-Control and Expires http headers
900 sub CacheControlExpiresHeaders {
903 my $Visibility = 'private';
904 if ( ! defined $args{Time} ) {
906 } elsif ( $args{Time} eq 'no-cache' ) {
908 } elsif ( $args{Time} eq 'forever' ) {
909 $args{Time} = 30 * 24 * 60 * 60;
910 $Visibility = 'public';
913 my $CacheControl = $args{Time}
914 ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
917 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
919 my $expires = RT::Date->new(RT->SystemUser);
921 $expires->AddSeconds( $args{Time} ) if $args{Time};
923 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
926 =head2 StaticFileHeaders
928 Send the browser a few headers to try to get it to (somewhat agressively)
929 cache RT's static Javascript and CSS files.
931 This routine could really use _accurate_ heuristics. (XXX TODO)
935 sub StaticFileHeaders {
936 my $date = RT::Date->new(RT->SystemUser);
938 # remove any cookie headers -- if it is cached publicly, it
939 # shouldn't include anyone's cookie!
940 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
942 # Expire things in a month.
943 CacheControlExpiresHeaders( Time => 'forever' );
945 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
946 # request, but we don't handle it and generate full reply again
947 # Last modified at server start time
948 # $date->Set( Value => $^T );
949 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
952 =head2 ComponentPathIsSafe PATH
954 Takes C<PATH> and returns a boolean indicating that the user-specified partial
955 component path is safe.
957 Currently "safe" means that the path does not start with a dot (C<.>), does
958 not contain a slash-dot C</.>, and does not contain any nulls.
962 sub ComponentPathIsSafe {
965 return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
970 Takes a C<< Path => path >> and returns a boolean indicating that
971 the path is safely within RT's control or not. The path I<must> be
974 This function does not consult the filesystem at all; it is merely
975 a logical sanity checking of the path. This explicitly does not handle
976 symlinks; if you have symlinks in RT's webroot pointing outside of it,
977 then we assume you know what you are doing.
984 my $path = $args{Path};
986 # Get File::Spec to clean up extra /s, ./, etc
987 my $cleaned_up = File::Spec->canonpath($path);
989 if (!defined($cleaned_up)) {
990 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
994 # Forbid too many ..s. We can't just sum then check because
995 # "../foo/bar/baz" should be illegal even though it has more
996 # downdirs than updirs. So as soon as we get a negative score
997 # (which means "breaking out" of the top level) we reject the path.
999 my @components = split '/', $cleaned_up;
1001 for my $component (@components) {
1002 if ($component eq '..') {
1005 $RT::Logger->info("Rejecting unsafe path: $path");
1009 elsif ($component eq '.' || $component eq '') {
1010 # these two have no effect on $score
1020 =head2 SendStaticFile
1022 Takes a File => path and a Type => Content-type
1024 If Type isn't provided and File is an image, it will
1025 figure out a sane Content-type, otherwise it will
1026 send application/octet-stream
1028 Will set caching headers using StaticFileHeaders
1032 sub SendStaticFile {
1035 my $file = $args{File};
1036 my $type = $args{Type};
1037 my $relfile = $args{RelativeFile};
1039 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1040 $HTML::Mason::Commands::r->status(400);
1041 $HTML::Mason::Commands::m->abort;
1044 $self->StaticFileHeaders();
1047 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1049 $type =~ s/jpg/jpeg/gi;
1051 $type ||= "application/octet-stream";
1053 $HTML::Mason::Commands::r->content_type($type);
1054 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1058 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1059 $HTML::Mason::Commands::m->flush_buffer;
1070 if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
1081 my $content = $args{Content};
1082 return '' unless $content;
1084 # Make the content have no 'weird' newlines in it
1085 $content =~ s/\r+\n/\n/g;
1087 my $return_content = $content;
1089 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1090 my $sigonly = $args{StripSignature};
1092 # massage content to easily detect if there's any real content
1093 $content =~ s/\s+//g; # yes! remove all the spaces
1095 # remove html version of spaces and newlines
1096 $content =~ s! !!g;
1097 $content =~ s!<br/?>!!g;
1100 # Filter empty content when type is text/html
1101 return '' if $html && $content !~ /\S/;
1103 # If we aren't supposed to strip the sig, just bail now.
1104 return $return_content unless $sigonly;
1106 # Find the signature
1107 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1110 # Check for plaintext sig
1111 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1113 # Check for html-formatted sig; we don't use EscapeUTF8 here
1114 # because we want to precisely match the escapting that FCKEditor
1116 $sig =~ s/&/&/g;
1119 $sig =~ s/"/"/g;
1120 $sig =~ s/'/'/g;
1121 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1124 return $return_content;
1132 # if they've passed multiple values, they'll be an array. if they've
1133 # passed just one, a scalar whatever they are, mark them as utf8
1136 ? Encode::is_utf8($_)
1138 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1139 : ( $type eq 'ARRAY' )
1140 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1142 : ( $type eq 'HASH' )
1143 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1149 sub PreprocessTimeUpdates {
1152 # Later in the code we use
1153 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1154 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1155 # The call_next method pass through original arguments and if you have
1156 # an argument with unicode key then in a next component you'll get two
1157 # records in the args hash: one with key without UTF8 flag and another
1158 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1159 # is copied from mason's source to get the same results as we get from
1160 # call_next method, this feature is not documented, so we just leave it
1161 # here to avoid possible side effects.
1163 # This code canonicalizes time inputs in hours into minutes
1164 foreach my $field ( keys %$ARGS ) {
1165 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1167 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1168 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1169 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1170 $ARGS->{$local} *= 60;
1172 delete $ARGS->{$field};
1177 sub MaybeEnableSQLStatementLog {
1179 my $log_sql_statements = RT->Config->Get('StatementLog');
1181 if ($log_sql_statements) {
1182 $RT::Handle->ClearSQLStatementLog;
1183 $RT::Handle->LogSQLStatements(1);
1188 sub LogRecordedSQLStatements {
1191 my $log_sql_statements = RT->Config->Get('StatementLog');
1193 return unless ($log_sql_statements);
1195 my @log = $RT::Handle->SQLStatementLog;
1196 $RT::Handle->ClearSQLStatementLog;
1198 $RT::Handle->AddRequestToHistory({
1199 %{ $args{RequestData} },
1203 for my $stmt (@log) {
1204 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1214 level => $log_sql_statements,
1216 . sprintf( "%.6f", $duration )
1218 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1224 my $_has_validated_web_config = 0;
1225 sub ValidateWebConfig {
1228 # do this once per server instance, not once per request
1229 return if $_has_validated_web_config;
1230 $_has_validated_web_config = 1;
1232 my $port = $ENV{SERVER_PORT};
1233 my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1234 || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
1235 ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1237 if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1238 $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
1239 ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1240 ."otherwise your internal links may be broken.");
1243 if ( $host ne RT->Config->Get('WebDomain') ) {
1244 $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
1245 ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1246 ."otherwise your internal links may be broken.");
1249 return; #next warning flooding our logs, doesn't seem applicable to our use
1250 # (SCRIPT_NAME is the full path, WebPath is just the beginning)
1251 #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
1253 # Unfortunately, there is no reliable way to get the _path_ that was
1254 # requested at the proxy level; simply disable this warning if we're
1255 # proxied and there's a mismatch.
1256 my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1257 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1258 $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
1259 ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1260 ."otherwise your internal links may be broken.");
1264 sub ComponentRoots {
1266 my %args = ( Names => 0, @_ );
1268 if (defined $HTML::Mason::Commands::m) {
1269 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1272 [ local => $RT::MasonLocalComponentRoot ],
1273 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1274 [ standard => $RT::MasonComponentRoot ]
1277 @roots = map { $_->[1] } @roots unless $args{Names};
1281 our %is_whitelisted_component = (
1282 # The RSS feed embeds an auth token in the path, but query
1283 # information for the search. Because it's a straight-up read, in
1284 # addition to embedding its own auth, it's fine.
1285 '/NoAuth/rss/dhandler' => 1,
1287 # While these can be used for denial-of-service against RT
1288 # (construct a very inefficient query and trick lots of users into
1289 # running them against RT) it's incredibly useful to be able to link
1290 # to a search result (or chart) or bookmark a result page.
1291 '/Search/Results.html' => 1,
1292 '/Search/Simple.html' => 1,
1293 '/m/tickets/search' => 1,
1294 '/Search/Chart.html' => 1,
1296 # This page takes Attachment and Transaction argument to figure
1297 # out what to show, but it's read only and will deny information if you
1298 # don't have ShowOutgoingEmail.
1299 '/Ticket/ShowEmailRecord.html' => 1,
1302 # Components which are blacklisted from automatic, argument-based whitelisting.
1303 # These pages are not idempotent when called with just an id.
1304 our %is_blacklisted_component = (
1305 # Takes only id and toggles bookmark state
1306 '/Helpers/Toggle/TicketBookmark' => 1,
1309 sub IsCompCSRFWhitelisted {
1313 return 1 if $is_whitelisted_component{$comp};
1315 my %args = %{ $ARGS };
1317 # If the user specifies a *correct* user and pass then they are
1318 # golden. This acts on the presumption that external forms may
1319 # hardcode a username and password -- if a malicious attacker knew
1320 # both already, CSRF is the least of your problems.
1321 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1322 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1323 my $user_obj = RT::CurrentUser->new();
1324 $user_obj->Load($args{user});
1325 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1331 # Some pages aren't idempotent even with safe args like id; blacklist
1332 # them from the automatic whitelisting below.
1333 return 0 if $is_blacklisted_component{$comp};
1335 # Eliminate arguments that do not indicate an effectful request.
1336 # For example, "id" is acceptable because that is how RT retrieves a
1340 # If they have a results= from MaybeRedirectForResults, that's also fine.
1341 delete $args{results};
1343 # The homepage refresh, which uses the Refresh header, doesn't send
1344 # a referer in most browsers; whitelist the one parameter it reloads
1345 # with, HomeRefreshInterval, which is safe
1346 delete $args{HomeRefreshInterval};
1348 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1349 # in the session related to which interface you get.
1350 delete $args{NotMobile};
1352 # If there are no arguments, then it's likely to be an idempotent
1353 # request, which are not susceptible to CSRF
1359 sub IsRefererCSRFWhitelisted {
1360 my $referer = _NormalizeHost(shift);
1361 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1362 $base_url = $base_url->host_port;
1365 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1366 push @$configs,$config;
1368 my $host_port = $referer->host_port;
1369 if ($config =~ /\*/) {
1370 # Turn a literal * into a domain component or partial component match.
1371 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1372 my $regex = join "[a-zA-Z0-9\-]*",
1373 map { quotemeta($_) }
1374 split /\*/, $config;
1376 return 1 if $host_port =~ /^$regex$/i;
1378 return 1 if $host_port eq $config;
1382 return (0,$referer,$configs);
1385 =head3 _NormalizeHost
1387 Takes a URI and creates a URI object that's been normalized
1388 to handle common problems such as localhost vs 127.0.0.1
1392 sub _NormalizeHost {
1394 $s = "http://$s" unless $s =~ /^http/i;
1395 my $uri= URI->new($s);
1396 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1402 sub IsPossibleCSRF {
1405 # If first request on this session is to a REST endpoint, then
1406 # whitelist the REST endpoints -- and explicitly deny non-REST
1407 # endpoints. We do this because using a REST cookie in a browser
1408 # would open the user to CSRF attacks to the REST endpoints.
1409 my $path = $HTML::Mason::Commands::r->path_info;
1410 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1411 unless defined $HTML::Mason::Commands::session{'REST'};
1413 if ($HTML::Mason::Commands::session{'REST'}) {
1414 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1416 This login session belongs to a REST client, and cannot be used to
1417 access non-REST interfaces of RT for security reasons.
1419 my $details = <<EOT;
1420 Please log out and back in to obtain a session for normal browsing. If
1421 you understand the security implications, disabling RT's CSRF protection
1422 will remove this restriction.
1425 HTML::Mason::Commands::Abort( $why, Details => $details );
1428 return 0 if IsCompCSRFWhitelisted(
1429 $HTML::Mason::Commands::m->request_comp->path,
1433 # if there is no Referer header then assume the worst
1435 "your browser did not supply a Referrer header", # loc
1436 ) if !$ENV{HTTP_REFERER};
1438 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1439 return 0 if $whitelisted;
1441 if ( @$configs > 1 ) {
1443 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1444 $browser->host_port,
1446 join(', ', @$configs) );
1450 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1451 $browser->host_port,
1455 sub ExpandCSRFToken {
1458 my $token = delete $ARGS->{CSRF_Token};
1459 return unless $token;
1461 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1462 return unless $data;
1463 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1465 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1466 return unless $user->ValidateAuthString( $data->{auth}, $token );
1468 %{$ARGS} = %{$data->{args}};
1469 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1471 # We explicitly stored file attachments with the request, but not in
1472 # the session yet, as that would itself be an attack. Put them into
1473 # the session now, so they'll be visible.
1474 if ($data->{attach}) {
1475 my $filename = $data->{attach}{filename};
1476 my $mime = $data->{attach}{mime};
1477 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1484 sub StoreRequestToken {
1487 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1488 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1490 auth => $user->GenerateAuthString( $token ),
1491 path => $HTML::Mason::Commands::r->path_info,
1494 if ($ARGS->{Attach}) {
1495 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1496 my $file_path = delete $ARGS->{'Attach'};
1498 filename => Encode::decode_utf8("$file_path"),
1499 mime => $attachment,
1503 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1504 $HTML::Mason::Commands::session{'i'}++;
1508 sub MaybeShowInterstitialCSRFPage {
1511 return unless RT->Config->Get('RestrictReferrer');
1513 # Deal with the form token provided by the interstitial, which lets
1514 # browsers which never set referer headers still use RT, if
1515 # painfully. This blows values into ARGS
1516 return if ExpandCSRFToken($ARGS);
1518 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1519 return if !$is_csrf;
1521 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1523 my $token = StoreRequestToken($ARGS);
1524 $HTML::Mason::Commands::m->comp(
1526 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1527 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1530 # Calls abort, never gets here
1533 our @POTENTIAL_PAGE_ACTIONS = (
1534 qr'/Ticket/Create.html' => "create a ticket", # loc
1535 qr'/Ticket/' => "update a ticket", # loc
1536 qr'/Admin/' => "modify RT's configuration", # loc
1537 qr'/Approval/' => "update an approval", # loc
1538 qr'/Articles/' => "update an article", # loc
1539 qr'/Dashboards/' => "modify a dashboard", # loc
1540 qr'/m/ticket/' => "update a ticket", # loc
1541 qr'Prefs' => "modify your preferences", # loc
1542 qr'/Search/' => "modify or access a search", # loc
1543 qr'/SelfService/Create' => "create a ticket", # loc
1544 qr'/SelfService/' => "update a ticket", # loc
1547 sub PotentialPageAction {
1549 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1550 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1551 return HTML::Mason::Commands::loc($result)
1552 if $page =~ $pattern;
1557 package HTML::Mason::Commands;
1559 use vars qw/$r $m %session/;
1562 return $HTML::Mason::Commands::m->notes('menu');
1566 return $HTML::Mason::Commands::m->notes('page-menu');
1570 return $HTML::Mason::Commands::m->notes('page-widgets');
1577 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1578 with whatever it's called with. If there is no $session{'CurrentUser'},
1579 it creates a temporary user, so we have something to get a localisation handle
1586 if ( $session{'CurrentUser'}
1587 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1589 return ( $session{'CurrentUser'}->loc(@_) );
1592 RT::CurrentUser->new();
1596 return ( $u->loc(@_) );
1599 # pathetic case -- SystemUser is gone.
1606 =head2 loc_fuzzy STRING
1608 loc_fuzzy is for handling localizations of messages that may already
1609 contain interpolated variables, typically returned from libraries
1610 outside RT's control. It takes the message string and extracts the
1611 variable array automatically by matching against the candidate entries
1612 inside the lexicon file.
1619 if ( $session{'CurrentUser'}
1620 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1622 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1624 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1625 return ( $u->loc_fuzzy($msg) );
1630 # Error - calls Error and aborts
1635 if ( $session{'ErrorDocument'}
1636 && $session{'ErrorDocumentType'} )
1638 $r->content_type( $session{'ErrorDocumentType'} );
1639 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1642 $m->comp( "/Elements/Error", Why => $why, %args );
1647 sub MaybeRedirectForResults {
1649 Path => $HTML::Mason::Commands::m->request_comp->path,
1656 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1657 return unless $has_actions || $args{'Force'};
1659 my %arguments = %{ $args{'Arguments'} };
1661 if ( $has_actions ) {
1662 my $key = Digest::MD5::md5_hex( rand(1024) );
1663 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1665 $arguments{'results'} = $key;
1668 $args{'Path'} =~ s!^/+!!;
1669 my $url = RT->Config->Get('WebURL') . $args{Path};
1671 if ( keys %arguments ) {
1672 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1674 if ( $args{'Anchor'} ) {
1675 $url .= "#". $args{'Anchor'};
1677 return RT::Interface::Web::Redirect($url);
1680 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1682 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1683 redirect to the approvals display page, preserving any arguments.
1685 C<Path>s matching C<Whitelist> are let through.
1687 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1691 sub MaybeRedirectToApproval {
1693 Path => $HTML::Mason::Commands::m->request_comp->path,
1699 return unless $ENV{REQUEST_METHOD} eq 'GET';
1701 my $id = $args{ARGSRef}->{id};
1704 and RT->Config->Get('ForceApprovalsView')
1705 and not $args{Path} =~ /$args{Whitelist}/)
1707 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1710 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1711 MaybeRedirectForResults(
1712 Path => "/Approvals/Display.html",
1714 Anchor => $args{ARGSRef}->{Anchor},
1715 Arguments => $args{ARGSRef},
1721 =head2 CreateTicket ARGS
1723 Create a new ticket, using Mason's %ARGS. returns @results.
1732 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1734 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1735 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1736 Abort('Queue not found');
1739 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1740 Abort('You have no permission to create tickets in that queue.');
1744 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1745 $due = RT::Date->new( $session{'CurrentUser'} );
1746 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1749 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1750 $starts = RT::Date->new( $session{'CurrentUser'} );
1751 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1754 my $sigless = RT::Interface::Web::StripContent(
1755 Content => $ARGS{Content},
1756 ContentType => $ARGS{ContentType},
1757 StripSignature => 1,
1758 CurrentUser => $session{'CurrentUser'},
1761 my $MIMEObj = MakeMIMEEntity(
1762 Subject => $ARGS{'Subject'},
1763 From => $ARGS{'From'},
1766 Type => $ARGS{'ContentType'},
1767 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1770 if ( $ARGS{'Attachments'} ) {
1771 my $rv = $MIMEObj->make_multipart;
1772 $RT::Logger->error("Couldn't make multipart message")
1773 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1775 foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
1777 $RT::Logger->error("Couldn't add empty attachemnt");
1780 $MIMEObj->add_part($_);
1784 for my $argument (qw(Encrypt Sign)) {
1785 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1789 Type => $ARGS{'Type'} || 'ticket',
1790 Queue => $ARGS{'Queue'},
1791 Owner => $ARGS{'Owner'},
1794 Requestor => $ARGS{'Requestors'},
1796 AdminCc => $ARGS{'AdminCc'},
1797 InitialPriority => $ARGS{'InitialPriority'},
1798 FinalPriority => $ARGS{'FinalPriority'},
1799 TimeLeft => $ARGS{'TimeLeft'},
1800 TimeEstimated => $ARGS{'TimeEstimated'},
1801 TimeWorked => $ARGS{'TimeWorked'},
1802 Subject => $ARGS{'Subject'},
1803 Status => $ARGS{'Status'},
1804 Due => $due ? $due->ISO : undef,
1805 Starts => $starts ? $starts->ISO : undef,
1810 foreach my $type (qw(Requestor Cc AdminCc)) {
1811 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1812 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1814 $create_args{TransSquelchMailTo} = \@txn_squelch
1817 if ( $ARGS{'AttachTickets'} ) {
1818 require RT::Action::SendEmail;
1819 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1820 ref $ARGS{'AttachTickets'}
1821 ? @{ $ARGS{'AttachTickets'} }
1822 : ( $ARGS{'AttachTickets'} ) );
1825 foreach my $arg ( keys %ARGS ) {
1826 next if $arg =~ /-(?:Magic|Category)$/;
1828 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1829 $create_args{$arg} = $ARGS{$arg};
1832 # Object-RT::Ticket--CustomField-3-Values
1833 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1836 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1837 $cf->SetContextObject( $Queue );
1839 unless ( $cf->id ) {
1840 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1844 if ( $arg =~ /-Upload$/ ) {
1845 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1849 my $type = $cf->Type;
1852 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1853 @values = @{ $ARGS{$arg} };
1854 } elsif ( $type =~ /text/i ) {
1855 @values = ( $ARGS{$arg} );
1857 no warnings 'uninitialized';
1858 @values = split /\r*\n/, $ARGS{$arg};
1860 @values = grep length, map {
1866 grep defined, @values;
1868 $create_args{"CustomField-$cfid"} = \@values;
1872 # turn new link lists into arrays, and pass in the proper arguments
1874 'new-DependsOn' => 'DependsOn',
1875 'DependsOn-new' => 'DependedOnBy',
1876 'new-MemberOf' => 'Parents',
1877 'MemberOf-new' => 'Children',
1878 'new-RefersTo' => 'RefersTo',
1879 'RefersTo-new' => 'ReferredToBy',
1881 foreach my $key ( keys %map ) {
1882 next unless $ARGS{$key};
1883 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1887 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1892 push( @Actions, split( "\n", $ErrMsg ) );
1893 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1894 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1896 return ( $Ticket, @Actions );
1902 =head2 LoadTicket id
1904 Takes a ticket id as its only variable. if it's handed an array, it takes
1907 Returns an RT::Ticket object as the current user.
1914 if ( ref($id) eq "ARRAY" ) {
1919 Abort("No ticket specified");
1922 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1924 unless ( $Ticket->id ) {
1925 Abort("Could not load ticket $id");
1932 =head2 ProcessUpdateMessage
1934 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1936 Don't write message if it only contains current user's signature and
1937 SkipSignatureOnly argument is true. Function anyway adds attachments
1938 and updates time worked field even if skips message. The default value
1943 # change from stock: if txn custom fields are set but there's no content
1944 # or attachment, create a Touch txn instead of doing nothing
1946 sub ProcessUpdateMessage {
1951 SkipSignatureOnly => 1,
1955 if ( $args{ARGSRef}->{'UpdateAttachments'}
1956 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1958 delete $args{ARGSRef}->{'UpdateAttachments'};
1961 # Strip the signature
1962 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1963 Content => $args{ARGSRef}->{UpdateContent},
1964 ContentType => $args{ARGSRef}->{UpdateContentType},
1965 StripSignature => $args{SkipSignatureOnly},
1966 CurrentUser => $args{'TicketObj'}->CurrentUser,
1969 my %txn_customfields;
1971 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1972 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1973 next if $key =~ /(TimeUnits|Magic)$/;
1974 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1978 # If, after stripping the signature, we have no message, create a
1979 # Touch transaction if necessary
1980 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1981 and not length $args{ARGSRef}->{'UpdateContent'} )
1983 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1984 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1985 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1988 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1989 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1990 my ( $Transaction, $Description, $Object ) =
1991 $args{TicketObj}->Touch(
1992 CustomFields => \%txn_customfields,
1993 TimeTaken => $timetaken
1995 return $Description;
2000 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
2001 $args{ARGSRef}->{'UpdateSubject'} = undef;
2004 my $Message = MakeMIMEEntity(
2005 Subject => $args{ARGSRef}->{'UpdateSubject'},
2006 Body => $args{ARGSRef}->{'UpdateContent'},
2007 Type => $args{ARGSRef}->{'UpdateContentType'},
2008 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2011 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
2012 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2014 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2015 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2016 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2018 $old_txn = $args{TicketObj}->Transactions->First();
2021 if ( my $msg = $old_txn->Message->First ) {
2022 RT::Interface::Email::SetInReplyTo(
2023 Message => $Message,
2028 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2029 $Message->make_multipart;
2030 $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
2031 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2034 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2035 require RT::Action::SendEmail;
2036 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2037 ref $args{ARGSRef}->{'AttachTickets'}
2038 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2039 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2042 my %message_args = (
2043 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2044 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2045 MIMEObj => $Message,
2046 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2047 CustomFields => \%txn_customfields,
2050 _ProcessUpdateMessageRecipients(
2051 MessageArgs => \%message_args,
2056 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2057 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2058 push( @results, $Description );
2059 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2060 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2061 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2062 push( @results, $Description );
2063 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2066 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2071 sub _ProcessUpdateMessageRecipients {
2075 MessageArgs => undef,
2079 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2080 my $cc = $args{ARGSRef}->{'UpdateCc'};
2082 my $message_args = $args{MessageArgs};
2084 $message_args->{CcMessageTo} = $cc;
2085 $message_args->{BccMessageTo} = $bcc;
2088 foreach my $type (qw(Cc AdminCc)) {
2089 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2090 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2091 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2092 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2095 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2096 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2097 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2100 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2101 $message_args->{SquelchMailTo} = \@txn_squelch
2104 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2105 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2106 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2108 my $var = ucfirst($1) . 'MessageTo';
2110 if ( $message_args->{$var} ) {
2111 $message_args->{$var} .= ", $value";
2113 $message_args->{$var} = $value;
2119 sub ProcessAttachments {
2125 my $ARGSRef = $args{ARGSRef} || {};
2126 # deal with deleting uploaded attachments
2127 foreach my $key ( keys %$ARGSRef ) {
2128 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2129 delete $session{'Attachments'}{$1};
2131 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2134 # store the uploaded attachment in session
2135 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2137 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2139 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2140 $session{'Attachments'} =
2141 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2144 # delete temporary storage entry to make WebUI clean
2145 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2147 delete $session{'Attachments'};
2152 =head2 MakeMIMEEntity PARAMHASH
2154 Takes a paramhash Subject, Body and AttachmentFieldName.
2156 Also takes Form, Cc and Type as optional paramhash keys.
2158 Returns a MIME::Entity.
2162 sub MakeMIMEEntity {
2164 #TODO document what else this takes.
2170 AttachmentFieldName => undef,
2175 my $Message = MIME::Entity->build(
2176 Type => 'multipart/mixed',
2177 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2178 "X-RT-Interface" => $args{Interface},
2179 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2180 grep defined $args{$_}, qw(Subject From Cc)
2183 if ( defined $args{'Body'} && length $args{'Body'} ) {
2185 # Make the update content have no 'weird' newlines in it
2186 $args{'Body'} =~ s/\r\n/\n/gs;
2189 Type => $args{'Type'} || 'text/plain',
2191 Data => $args{'Body'},
2195 if ( $args{'AttachmentFieldName'} ) {
2197 my $cgi_object = $m->cgi_object;
2198 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2199 if ( defined $filehandle && length $filehandle ) {
2201 my ( @content, $buffer );
2202 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2203 push @content, $buffer;
2206 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2208 my $filename = "$filehandle";
2209 $filename =~ s{^.*[\\/]}{};
2212 Type => $uploadinfo->{'Content-Type'},
2213 Filename => $filename,
2216 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2217 $Message->head->set( 'Subject' => $filename );
2220 # Attachment parts really shouldn't get a Message-ID or "interface"
2221 $Message->head->delete('Message-ID');
2222 $Message->head->delete('X-RT-Interface');
2226 $Message->make_singlepart;
2228 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2236 =head2 ParseDateToISO
2238 Takes a date in an arbitrary format.
2239 Returns an ISO date and time in GMT
2243 sub ParseDateToISO {
2246 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2248 Format => 'unknown',
2251 return ( $date_obj->ISO );
2256 sub ProcessACLChanges {
2257 my $ARGSref = shift;
2261 foreach my $arg ( keys %$ARGSref ) {
2262 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2264 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2267 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2268 @rights = @{ $ARGSref->{$arg} };
2270 @rights = $ARGSref->{$arg};
2272 @rights = grep $_, @rights;
2273 next unless @rights;
2275 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2276 $principal->Load($principal_id);
2279 if ( $object_type eq 'RT::System' ) {
2281 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2282 $obj = $object_type->new( $session{'CurrentUser'} );
2283 $obj->Load($object_id);
2284 unless ( $obj->id ) {
2285 $RT::Logger->error("couldn't load $object_type #$object_id");
2289 $RT::Logger->error("object type '$object_type' is incorrect");
2290 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2294 foreach my $right (@rights) {
2295 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2296 push( @results, $msg );
2306 ProcessACLs expects values from a series of checkboxes that describe the full
2307 set of rights a principal should have on an object.
2309 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2310 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2311 listing the rights the principal should have, and ProcessACLs will modify the
2312 current rights to match. Additionally, the previously unused CheckACL input
2313 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2314 rights are removed from a principal and as such no SetRights input is
2320 my $ARGSref = shift;
2321 my (%state, @results);
2323 my $CheckACL = $ARGSref->{'CheckACL'};
2324 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2326 # Check if we want to grant rights to a previously rights-less user
2327 for my $type (qw(user group)) {
2328 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2331 unless ($principal->PrincipalId) {
2332 push @results, loc("Couldn't load the specified principal");
2336 my $principal_id = $principal->PrincipalId;
2338 # Turn our addprincipal rights spec into a real one
2339 for my $arg (keys %$ARGSref) {
2340 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2342 my $tuple = "$principal_id-$1";
2343 my $key = "SetRights-$tuple";
2345 # If we have it already, that's odd, but merge them
2346 if (grep { $_ eq $tuple } @check) {
2347 $ARGSref->{$key} = [
2348 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2349 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2352 $ARGSref->{$key} = $ARGSref->{$arg};
2353 push @check, $tuple;
2358 # Build our rights state for each Principal-Object tuple
2359 foreach my $arg ( keys %$ARGSref ) {
2360 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2363 my $value = $ARGSref->{$arg};
2364 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2365 next unless @rights;
2367 $state{$tuple} = { map { $_ => 1 } @rights };
2370 foreach my $tuple (List::MoreUtils::uniq @check) {
2371 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2373 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2375 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2376 $principal->Load($principal_id);
2379 if ( $object_type eq 'RT::System' ) {
2381 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2382 $obj = $object_type->new( $session{'CurrentUser'} );
2383 $obj->Load($object_id);
2384 unless ( $obj->id ) {
2385 $RT::Logger->error("couldn't load $object_type #$object_id");
2389 $RT::Logger->error("object type '$object_type' is incorrect");
2390 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2394 my $acls = RT::ACL->new($session{'CurrentUser'});
2395 $acls->LimitToObject( $obj );
2396 $acls->LimitToPrincipal( Id => $principal_id );
2398 while ( my $ace = $acls->Next ) {
2399 my $right = $ace->RightName;
2401 # Has right and should have right
2402 next if delete $state{$tuple}->{$right};
2404 # Has right and shouldn't have right
2405 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2406 push @results, $msg;
2409 # For everything left, they don't have the right but they should
2410 for my $right (keys %{ $state{$tuple} || {} }) {
2411 delete $state{$tuple}->{$right};
2412 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2413 push @results, $msg;
2416 # Check our state for leftovers
2417 if ( keys %{ $state{$tuple} || {} } ) {
2418 my $missed = join '|', %{$state{$tuple} || {}};
2420 "Uh-oh, it looks like we somehow missed a right in "
2421 ."ProcessACLs. Here's what was leftover: $missed"
2429 =head2 _ParseACLNewPrincipal
2431 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2432 for the presence of rights being added on a principal of the specified type,
2433 and returns undef if no new principal is being granted rights. Otherwise loads
2434 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2435 may not be successfully loaded, and you should check C<->id> yourself.
2439 sub _ParseACLNewPrincipal {
2440 my $ARGSref = shift;
2441 my $type = lc shift;
2442 my $key = "AddPrincipalForRights-$type";
2444 return unless $ARGSref->{$key};
2447 if ( $type eq 'user' ) {
2448 $principal = RT::User->new( $session{'CurrentUser'} );
2449 $principal->LoadByCol( Name => $ARGSref->{$key} );
2451 elsif ( $type eq 'group' ) {
2452 $principal = RT::Group->new( $session{'CurrentUser'} );
2453 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2459 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2461 @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.
2463 Returns an array of success/failure messages
2467 sub UpdateRecordObject {
2470 AttributesRef => undef,
2472 AttributePrefix => undef,
2476 my $Object = $args{'Object'};
2477 my @results = $Object->Update(
2478 AttributesRef => $args{'AttributesRef'},
2479 ARGSRef => $args{'ARGSRef'},
2480 AttributePrefix => $args{'AttributePrefix'},
2488 sub ProcessCustomFieldUpdates {
2490 CustomFieldObj => undef,
2495 my $Object = $args{'CustomFieldObj'};
2496 my $ARGSRef = $args{'ARGSRef'};
2498 my @attribs = qw(Name Type Description Queue SortOrder);
2499 my @results = UpdateRecordObject(
2500 AttributesRef => \@attribs,
2505 my $prefix = "CustomField-" . $Object->Id;
2506 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2507 my ( $addval, $addmsg ) = $Object->AddValue(
2508 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2509 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2510 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2512 push( @results, $addmsg );
2516 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2517 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2518 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2520 foreach my $id (@delete_values) {
2521 next unless defined $id;
2522 my ( $err, $msg ) = $Object->DeleteValue($id);
2523 push( @results, $msg );
2526 my $vals = $Object->Values();
2527 while ( my $cfv = $vals->Next() ) {
2528 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2529 if ( $cfv->SortOrder != $so ) {
2530 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2531 push( @results, $msg );
2541 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2543 Returns an array of results messages.
2547 sub ProcessTicketBasics {
2555 my $TicketObj = $args{'TicketObj'};
2556 my $ARGSRef = $args{'ARGSRef'};
2558 my $OrigOwner = $TicketObj->Owner;
2573 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2574 for my $field (qw(Queue Owner)) {
2575 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2576 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2577 my $temp = $class->new(RT->SystemUser);
2578 $temp->Load( $ARGSRef->{$field} );
2580 $ARGSRef->{$field} = $temp->id;
2585 # Status isn't a field that can be set to a null value.
2586 # RT core complains if you try
2587 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2589 my @results = UpdateRecordObject(
2590 AttributesRef => \@attribs,
2591 Object => $TicketObj,
2592 ARGSRef => $ARGSRef,
2595 # We special case owner changing, so we can use ForceOwnerChange
2596 if ( $ARGSRef->{'Owner'}
2597 && $ARGSRef->{'Owner'} !~ /\D/
2598 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2600 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2601 $ChownType = "Force";
2607 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2608 push( @results, $msg );
2616 sub ProcessTicketReminders {
2623 my $Ticket = $args{'TicketObj'};
2624 my $args = $args{'ARGSRef'};
2627 my $reminder_collection = $Ticket->Reminders->Collection;
2629 if ( $args->{'update-reminders'} ) {
2630 while ( my $reminder = $reminder_collection->Next ) {
2631 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2632 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2633 my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
2634 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2637 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2638 my ($status, $msg) = $Ticket->Reminders->Open($reminder);
2639 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2642 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2643 my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2644 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2647 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2648 my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2649 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2652 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2653 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2655 Format => 'unknown',
2656 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2658 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2659 my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
2660 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2666 if ( $args->{'NewReminder-Subject'} ) {
2667 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2669 Format => 'unknown',
2670 Value => $args->{'NewReminder-Due'}
2672 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2673 Subject => $args->{'NewReminder-Subject'},
2674 Owner => $args->{'NewReminder-Owner'},
2675 Due => $due_obj->ISO
2678 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2681 push @results, $msg;
2687 sub ProcessTicketCustomFieldUpdates {
2689 $args{'Object'} = delete $args{'TicketObj'};
2690 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2692 # Build up a list of objects that we want to work with
2693 my %custom_fields_to_mod;
2694 foreach my $arg ( keys %$ARGSRef ) {
2695 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2696 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2697 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2698 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2699 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2700 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2704 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2707 sub ProcessObjectCustomFieldUpdates {
2709 my $ARGSRef = $args{'ARGSRef'};
2712 # Build up a list of objects that we want to work with
2713 my %custom_fields_to_mod;
2714 foreach my $arg ( keys %$ARGSRef ) {
2716 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2717 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2719 # For each of those objects, find out what custom fields we want to work with.
2720 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2723 # For each of those objects
2724 foreach my $class ( keys %custom_fields_to_mod ) {
2725 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2726 my $Object = $args{'Object'};
2727 $Object = $class->new( $session{'CurrentUser'} )
2728 unless $Object && ref $Object eq $class;
2730 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2731 unless ( $Object->id ) {
2732 $RT::Logger->warning("Couldn't load object $class #$id");
2736 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2737 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2738 $CustomFieldObj->SetContextObject($Object);
2739 $CustomFieldObj->LoadById($cf);
2740 unless ( $CustomFieldObj->id ) {
2741 $RT::Logger->warning("Couldn't load custom field #$cf");
2745 _ProcessObjectCustomFieldUpdates(
2746 Prefix => "Object-$class-$id-CustomField-$cf-",
2748 CustomField => $CustomFieldObj,
2749 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2757 sub _ProcessObjectCustomFieldUpdates {
2759 my $cf = $args{'CustomField'};
2760 my $cf_type = $cf->Type || '';
2762 # Remove blank Values since the magic field will take care of this. Sometimes
2763 # the browser gives you a blank value which causes CFs to be processed twice
2764 if ( defined $args{'ARGS'}->{'Values'}
2765 && !length $args{'ARGS'}->{'Values'}
2766 && $args{'ARGS'}->{'Values-Magic'} )
2768 delete $args{'ARGS'}->{'Values'};
2772 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2774 # skip category argument
2775 next if $arg eq 'Category';
2778 next if $arg eq 'Value-TimeUnits';
2780 # since http won't pass in a form element with a null value, we need
2782 if ( $arg eq 'Values-Magic' ) {
2784 # We don't care about the magic, if there's really a values element;
2785 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2786 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2788 # "Empty" values does not mean anything for Image and Binary fields
2789 next if $cf_type =~ /^(?:Image|Binary)$/;
2792 $args{'ARGS'}->{'Values'} = undef;
2796 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2797 @values = @{ $args{'ARGS'}->{$arg} };
2798 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2799 @values = ( $args{'ARGS'}->{$arg} );
2801 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2802 if defined $args{'ARGS'}->{$arg};
2804 @values = grep length, map {
2810 grep defined, @values;
2812 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2813 foreach my $value (@values) {
2814 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2818 push( @results, $msg );
2820 } elsif ( $arg eq 'Upload' ) {
2821 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2822 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2823 push( @results, $msg );
2824 } elsif ( $arg eq 'DeleteValues' ) {
2825 foreach my $value (@values) {
2826 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2830 push( @results, $msg );
2832 } elsif ( $arg eq 'DeleteValueIds' ) {
2833 foreach my $value (@values) {
2834 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2838 push( @results, $msg );
2840 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2841 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2844 foreach my $value (@values) {
2845 if ( my $entry = $cf_values->HasEntry($value) ) {
2846 $values_hash{ $entry->id } = 1;
2850 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2854 push( @results, $msg );
2855 $values_hash{$val} = 1 if $val;
2858 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2859 return @results if ( $cf->Type eq 'Date' && ! @values );
2861 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2862 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2864 $cf_values->RedoSearch;
2865 while ( my $cf_value = $cf_values->Next ) {
2866 next if $values_hash{ $cf_value->id };
2868 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2870 ValueId => $cf_value->id
2872 push( @results, $msg );
2874 } elsif ( $arg eq 'Values' ) {
2875 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2877 # keep everything up to the point of difference, delete the rest
2879 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2880 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2889 # now add/replace extra things, if any
2890 foreach my $value (@values) {
2891 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2895 push( @results, $msg );
2900 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2901 $cf->Name, ref $args{'Object'},
2911 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2913 Returns an array of results messages.
2917 sub ProcessTicketWatchers {
2925 my $Ticket = $args{'TicketObj'};
2926 my $ARGSRef = $args{'ARGSRef'};
2930 foreach my $key ( keys %$ARGSRef ) {
2932 # Delete deletable watchers
2933 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2934 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2938 push @results, $msg;
2941 # Delete watchers in the simple style demanded by the bulk manipulator
2942 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2943 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2944 Email => $ARGSRef->{$key},
2947 push @results, $msg;
2950 # Add new wathchers by email address
2951 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2952 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2955 #They're in this order because otherwise $1 gets clobbered :/
2956 my ( $code, $msg ) = $Ticket->AddWatcher(
2957 Type => $ARGSRef->{$key},
2958 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2960 push @results, $msg;
2963 #Add requestors in the simple style demanded by the bulk manipulator
2964 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2965 my ( $code, $msg ) = $Ticket->AddWatcher(
2967 Email => $ARGSRef->{$key}
2969 push @results, $msg;
2972 # Add new watchers by owner
2973 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2974 my $principal_id = $1;
2975 my $form = $ARGSRef->{$key};
2976 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2977 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2979 my ( $code, $msg ) = $Ticket->AddWatcher(
2981 PrincipalId => $principal_id
2983 push @results, $msg;
2993 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2995 Returns an array of results messages.
2999 sub ProcessTicketDates {
3006 my $Ticket = $args{'TicketObj'};
3007 my $ARGSRef = $args{'ARGSRef'};
3012 my @date_fields = qw(
3021 #Run through each field in this list. update the value if apropriate
3022 foreach my $field (@date_fields) {
3023 next unless exists $ARGSRef->{ $field . '_Date' };
3024 next if $ARGSRef->{ $field . '_Date' } eq '';
3028 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3030 Format => 'unknown',
3031 Value => $ARGSRef->{ $field . '_Date' }
3034 my $obj = $field . "Obj";
3035 if ( ( defined $DateObj->Unix )
3036 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3038 my $method = "Set$field";
3039 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3040 push @results, "$msg";
3050 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3052 Returns an array of results messages.
3056 sub ProcessTicketLinks {
3063 my $Ticket = $args{'TicketObj'};
3064 my $ARGSRef = $args{'ARGSRef'};
3066 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3068 #Merge if we need to
3069 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3070 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3071 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3072 push @results, $msg;
3079 sub ProcessRecordLinks {
3086 my $Record = $args{'RecordObj'};
3087 my $ARGSRef = $args{'ARGSRef'};
3091 # Delete links that are gone gone gone.
3092 foreach my $arg ( keys %$ARGSRef ) {
3093 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3098 my ( $val, $msg ) = $Record->DeleteLink(
3104 push @results, $msg;
3110 my @linktypes = qw( DependsOn MemberOf RefersTo );
3112 foreach my $linktype (@linktypes) {
3113 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3114 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3115 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3117 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3119 $luri =~ s/\s+$//; # Strip trailing whitespace
3120 my ( $val, $msg ) = $Record->AddLink(
3124 push @results, $msg;
3127 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3128 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3129 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3131 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3133 my ( $val, $msg ) = $Record->AddLink(
3138 push @results, $msg;
3146 =head2 ProcessTransactionSquelching
3148 Takes a hashref of the submitted form arguments, C<%ARGS>.
3150 Returns a hash of squelched addresses.
3154 sub ProcessTransactionSquelching {
3156 my %checked = map { $_ => 1 } grep { defined }
3157 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3158 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3160 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3164 =head2 _UploadedFile ( $arg );
3166 Takes a CGI parameter name; if a file is uploaded under that name,
3167 return a hash reference suitable for AddCustomFieldValue's use:
3168 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3170 Returns C<undef> if no files were uploaded in the C<$arg> field.
3176 my $cgi_object = $m->cgi_object;
3177 my $fh = $cgi_object->upload($arg) or return undef;
3178 my $upload_info = $cgi_object->uploadInfo($fh);
3180 my $filename = "$fh";
3181 $filename =~ s#^.*[\\/]##;
3186 LargeContent => do { local $/; scalar <$fh> },
3187 ContentType => $upload_info->{'Content-Type'},
3191 sub GetColumnMapEntry {
3192 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3194 # deal with the simplest thing first
3195 if ( $args{'Map'}{ $args{'Name'} } ) {
3196 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3200 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3201 $subkey =~ s/^\{(.*)\}$/$1/;
3202 return undef unless $args{'Map'}->{$mainkey};
3203 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3204 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3206 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3211 sub ProcessColumnMapValue {
3213 my %args = ( Arguments => [], Escape => 1, @_ );
3216 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3217 my @tmp = $value->( @{ $args{'Arguments'} } );
3218 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3219 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3220 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3221 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3226 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3230 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3232 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3233 principal collections mapped from the categories given.
3237 sub GetPrincipalsMap {
3242 my $system = RT::Groups->new($session{'CurrentUser'});
3243 $system->LimitToSystemInternalGroups();
3244 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3246 'System' => $system, # loc_left_pair
3251 my $groups = RT::Groups->new($session{'CurrentUser'});
3252 $groups->LimitToUserDefinedGroups();
3253 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3255 # Only show groups who have rights granted on this object
3256 $groups->WithGroupRight(
3259 IncludeSystemRights => 0,
3260 IncludeSubgroupMembers => 0,
3264 'User Groups' => $groups, # loc_left_pair
3269 my $roles = RT::Groups->new($session{'CurrentUser'});
3271 if ($object->isa('RT::System')) {
3272 $roles->LimitToRolesForSystem();
3274 elsif ($object->isa('RT::Queue')) {
3275 $roles->LimitToRolesForQueue($object->Id);
3278 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3281 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3283 'Roles' => $roles, # loc_left_pair
3288 my $Users = RT->PrivilegedUsers->UserMembersObj();
3289 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3291 # Only show users who have rights granted on this object
3292 my $group_members = $Users->WhoHaveGroupRight(
3295 IncludeSystemRights => 0,
3296 IncludeSubgroupMembers => 0,
3299 # Limit to UserEquiv groups
3300 my $groups = $Users->NewAlias('Groups');
3304 ALIAS2 => $group_members,
3307 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3308 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3312 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3315 'Users' => $Users, # loc_left_pair
3323 =head2 _load_container_object ( $type, $id );
3325 Instantiate container object for saving searches.
3329 sub _load_container_object {
3330 my ( $obj_type, $obj_id ) = @_;
3331 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3334 =head2 _parse_saved_search ( $arg );
3336 Given a serialization string for saved search, and returns the
3337 container object and the search id.
3341 sub _parse_saved_search {
3343 return unless $spec;
3344 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3351 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3354 =head2 ScrubHTML content
3356 Removes unsafe and undesired HTML from the passed content
3362 my $Content = shift;
3363 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3365 $Content = '' if !defined($Content);
3366 return $SCRUBBER->scrub($Content);
3371 Returns a new L<HTML::Scrubber> object.
3373 If you need to be more lax about what HTML tags and attributes are allowed,
3374 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3377 package HTML::Mason::Commands;
3378 # Let tables through
3379 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3384 our @SCRUBBER_ALLOWED_TAGS = qw(
3385 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3386 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3389 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3390 # Match http, https, ftp, mailto and relative urls
3391 # XXX: we also scrub format strings with this module then allow simple config options
3392 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3398 (?:(?:background-)?color: \s*
3399 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3400 \#[a-f0-9]{3,6} | # #fff or #ffffff
3401 [\w\-]+ # green, light-blue, etc.
3403 text-align: \s* \w+ |
3404 font-size: \s* [\w.\-]+ |
3405 font-family: \s* [\w\s"',.\-]+ |
3406 font-weight: \s* [\w\-]+ |
3408 # MS Office styles, which are probably fine. If we don't, then any
3409 # associated styles in the same attribute get stripped.
3410 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3412 +$ # one or more of these allowed properties from here 'till sunset
3414 dir => qr/^(rtl|ltr)$/i,
3415 lang => qr/^\w+(-\w+)?$/,
3418 our %SCRUBBER_RULES = ();
3421 require HTML::Scrubber;
3422 my $scrubber = HTML::Scrubber->new();
3426 %SCRUBBER_ALLOWED_ATTRIBUTES,
3427 '*' => 0, # require attributes be explicitly allowed
3430 $scrubber->deny(qw[*]);
3431 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3432 $scrubber->rules(%SCRUBBER_RULES);
3434 # Scrubbing comments is vital since IE conditional comments can contain
3435 # arbitrary HTML and we'd pass it right on through.
3436 $scrubber->comment(0);
3443 Redispatches to L<RT::Interface::Web/EncodeJSON>
3448 RT::Interface::Web::EncodeJSON(@_);
3451 package RT::Interface::Web;
3452 RT::Base->_ImportOverlays();