1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2012 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 );
264 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
266 # Process session-related callbacks before any auth attempts
267 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
269 MaybeRejectPrivateComponentRequest();
271 MaybeShowNoAuthPage($ARGS);
273 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
275 _ForceLogout() unless _UserLoggedIn();
277 # Process per-page authentication callbacks
278 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
280 unless ( _UserLoggedIn() ) {
283 # Authenticate if the user is trying to login via user/pass query args
284 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
287 my $m = $HTML::Mason::Commands::m;
289 # REST urls get a special 401 response
290 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
291 $HTML::Mason::Commands::r->content_type("text/plain");
292 $m->error_format("text");
293 $m->out("RT/$RT::VERSION 401 Credentials required\n");
294 $m->out("\n$msg\n") if $msg;
297 # Specially handle /index.html so that we get a nicer URL
298 elsif ( $m->request_comp->path eq '/index.html' ) {
299 my $next = SetNextPage(RT->Config->Get('WebURL'));
300 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
304 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
309 MaybeShowInterstitialCSRFPage($ARGS);
311 # now it applies not only to home page, but any dashboard that can be used as a workspace
312 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
313 if ( $ARGS->{'HomeRefreshInterval'} );
315 # Process per-page global callbacks
316 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
318 ShowRequestedPage($ARGS);
319 LogRecordedSQLStatements(RequestData => {
320 Path => $HTML::Mason::Commands::m->request_comp->path,
323 # Process per-page final cleanup callbacks
324 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
326 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
327 unless $HTML::Mason::Commands::r->content_type
328 =~ qr<^(text|application)/(x-)?(css|javascript)>;
333 delete $HTML::Mason::Commands::session{'CurrentUser'};
337 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
345 =head2 LoginError ERROR
347 Pushes a login error into the Actions session store and returns the hash key.
353 my $key = Digest::MD5::md5_hex( rand(1024) );
354 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
355 $HTML::Mason::Commands::session{'i'}++;
359 =head2 SetNextPage [PATH]
361 Intuits and stashes the next page in the sesssion hash. If PATH is
362 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
368 my $next = shift || IntuitNextPage();
369 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
371 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
372 $HTML::Mason::Commands::session{'i'}++;
377 =head2 TangentForLogin [HASH]
379 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
380 the next page. Optionally takes a hash which is dumped into query params.
384 sub TangentForLogin {
385 my $hash = SetNextPage();
386 my %query = (@_, next => $hash);
387 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
388 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
392 =head2 TangentForLoginWithError ERROR
394 Localizes the passed error message, stashes it with L<LoginError> and then
395 calls L<TangentForLogin> with the appropriate results key.
399 sub TangentForLoginWithError {
400 my $key = LoginError(HTML::Mason::Commands::loc(@_));
401 TangentForLogin( results => $key );
404 =head2 IntuitNextPage
406 Attempt to figure out the path to which we should return the user after a
407 tangent. The current request URL is used, or failing that, the C<WebURL>
408 configuration variable.
415 # This includes any query parameters. Redirect will take care of making
416 # it an absolute URL.
417 if ($ENV{'REQUEST_URI'}) {
418 $req_uri = $ENV{'REQUEST_URI'};
420 # collapse multiple leading slashes so the first part doesn't look like
421 # a hostname of a schema-less URI
422 $req_uri =~ s{^/+}{/};
425 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
428 my $uri = URI->new($next);
430 # You get undef scheme with a relative uri like "/Search/Build.html"
431 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
432 $next = RT->Config->Get('WebURL');
435 # Make sure we're logging in to the same domain
436 # You can get an undef authority with a relative uri like "index.html"
437 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
438 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
439 $next = RT->Config->Get('WebURL');
445 =head2 MaybeShowInstallModePage
447 This function, called exclusively by RT's autohandler, dispatches
448 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
450 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
454 sub MaybeShowInstallModePage {
455 return unless RT->InstallMode;
457 my $m = $HTML::Mason::Commands::m;
458 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
460 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
461 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
468 =head2 MaybeShowNoAuthPage \%ARGS
470 This function, called exclusively by RT's autohandler, dispatches
471 a request to the page a user requested (but only if it matches the "noauth" regex.
473 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
477 sub MaybeShowNoAuthPage {
480 my $m = $HTML::Mason::Commands::m;
482 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
484 # Don't show the login page to logged in users
485 Redirect(RT->Config->Get('WebURL'))
486 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
488 # If it's a noauth file, don't ask for auth.
489 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
493 =head2 MaybeRejectPrivateComponentRequest
495 This function will reject calls to private components, like those under
496 C</Elements>. If the requested path is a private component then we will
497 abort with a C<403> error.
501 sub MaybeRejectPrivateComponentRequest {
502 my $m = $HTML::Mason::Commands::m;
503 my $path = $m->request_comp->path;
505 # We do not check for dhandler here, because requesting our dhandlers
506 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
512 _elements | # mobile UI
514 autohandler | # requesting this directly is suspicious
515 l (_unsafe)? ) # loc component
516 ( $ | / ) # trailing slash or end of path
518 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
521 warn "rejecting private component $path\n";
529 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
530 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
531 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
536 =head2 ShowRequestedPage \%ARGS
538 This function, called exclusively by RT's autohandler, dispatches
539 a request to the page a user requested (making sure that unpriviled users
540 can only see self-service pages.
544 sub ShowRequestedPage {
547 my $m = $HTML::Mason::Commands::m;
549 # Ensure that the cookie that we send is up-to-date, in case the
550 # session-id has been modified in any way
553 # precache all system level rights for the current user
554 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
556 # If the user isn't privileged, they can only see SelfService
557 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
559 # if the user is trying to access a ticket, redirect them
560 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
561 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
564 # otherwise, drop the user at the SelfService default page
565 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
566 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
569 # if user is in SelfService dir let him do anything
571 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
574 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
579 sub AttemptExternalAuth {
582 return unless ( RT->Config->Get('WebExternalAuth') );
584 my $user = $ARGS->{user};
585 my $m = $HTML::Mason::Commands::m;
587 # If RT is configured for external auth, let's go through and get REMOTE_USER
589 # do we actually have a REMOTE_USER equivlent?
590 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
591 my $orig_user = $user;
593 $user = RT::Interface::Web::WebCanonicalizeInfo();
594 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
596 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
597 my $NodeName = Win32::NodeName();
598 $user =~ s/^\Q$NodeName\E\\//i;
601 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
602 InstantiateNewSession() unless _UserLoggedIn;
603 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
604 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
606 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
608 # Create users on-the-fly
609 my $UserObj = RT::User->new(RT->SystemUser);
610 my ( $val, $msg ) = $UserObj->Create(
611 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
618 # now get user specific information, to better create our user.
619 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
621 # set the attributes that have been defined.
622 foreach my $attribute ( $UserObj->WritableAttributes ) {
624 Attribute => $attribute,
626 UserInfo => $new_user_info,
627 CallbackName => 'NewUser',
628 CallbackPage => '/autohandler'
630 my $method = "Set$attribute";
631 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
633 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
636 # we failed to successfully create the user. abort abort abort.
637 delete $HTML::Mason::Commands::session{'CurrentUser'};
639 if (RT->Config->Get('WebFallbackToInternalAuth')) {
640 TangentForLoginWithError('Cannot create user: [_1]', $msg);
647 if ( _UserLoggedIn() ) {
648 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
649 # It is possible that we did a redirect to the login page,
650 # if the external auth allows lack of auth through with no
651 # REMOTE_USER set, instead of forcing a "permission
652 # denied" message. Honor the $next.
653 Redirect($next) if $next;
654 # Unlike AttemptPasswordAuthentication below, we do not
655 # force a redirect to / if $next is not set -- otherwise,
656 # straight-up external auth would always redirect to /
657 # when you first hit it.
659 delete $HTML::Mason::Commands::session{'CurrentUser'};
662 if ( RT->Config->Get('WebExternalOnly') ) {
663 TangentForLoginWithError('You are not an authorized user');
666 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
667 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
668 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
669 TangentForLoginWithError('You are not an authorized user');
673 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
674 # XXX: we must return AUTH_REQUIRED status or we fallback to
675 # internal auth here too.
676 delete $HTML::Mason::Commands::session{'CurrentUser'}
677 if defined $HTML::Mason::Commands::session{'CurrentUser'};
681 sub AttemptPasswordAuthentication {
683 return unless defined $ARGS->{user} && defined $ARGS->{pass};
685 my $user_obj = RT::CurrentUser->new();
686 $user_obj->Load( $ARGS->{user} );
688 my $m = $HTML::Mason::Commands::m;
690 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
691 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
692 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
693 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
696 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
698 # It's important to nab the next page from the session before we blow
700 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
702 InstantiateNewSession();
703 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
705 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
707 # Really the only time we don't want to redirect here is if we were
708 # passed user and pass as query params in the URL.
712 elsif ($ARGS->{'next'}) {
713 # Invalid hash, but still wants to go somewhere, take them to /
714 Redirect(RT->Config->Get('WebURL'));
717 return (1, HTML::Mason::Commands::loc('Logged in'));
721 =head2 LoadSessionFromCookie
723 Load or setup a session cookie for the current user.
727 sub _SessionCookieName {
728 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
729 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
733 sub LoadSessionFromCookie {
735 my %cookies = CGI::Cookie->fetch;
736 my $cookiename = _SessionCookieName();
737 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
738 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
739 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
740 undef $cookies{$cookiename};
742 if ( int RT->Config->Get('AutoLogoff') ) {
743 my $now = int( time / 60 );
744 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
746 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
747 InstantiateNewSession();
750 # save session on each request when AutoLogoff is turned on
751 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
755 sub InstantiateNewSession {
756 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
757 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
761 sub SendSessionCookie {
762 my $cookie = CGI::Cookie->new(
763 -name => _SessionCookieName(),
764 -value => $HTML::Mason::Commands::session{_session_id},
765 -path => RT->Config->Get('WebPath'),
766 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
767 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
770 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
775 This routine ells the current user's browser to redirect to URL.
776 Additionally, it unties the user's currently active session, helping to avoid
777 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
778 a cached DBI statement handle twice at the same time.
783 my $redir_to = shift;
784 untie $HTML::Mason::Commands::session;
785 my $uri = URI->new($redir_to);
786 my $server_uri = URI->new( RT->Config->Get('WebURL') );
788 # Make relative URIs absolute from the server host and scheme
789 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
790 if (not defined $uri->host) {
791 $uri->host($server_uri->host);
792 $uri->port($server_uri->port);
795 # If the user is coming in via a non-canonical
796 # hostname, don't redirect them to the canonical host,
797 # it will just upset them (and invalidate their credentials)
798 # don't do this if $RT::CanonicalizeRedirectURLs is true
799 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
800 && $uri->host eq $server_uri->host
801 && $uri->port eq $server_uri->port )
803 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
804 $uri->scheme('https');
806 $uri->scheme('http');
809 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
810 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
811 $uri->port( $ENV{'SERVER_PORT'} );
814 # not sure why, but on some systems without this call mason doesn't
815 # set status to 302, but 200 instead and people see blank pages
816 $HTML::Mason::Commands::r->status(302);
818 # Perlbal expects a status message, but Mason's default redirect status
819 # doesn't provide one. See also rt.cpan.org #36689.
820 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
822 $HTML::Mason::Commands::m->abort;
825 =head2 StaticFileHeaders
827 Send the browser a few headers to try to get it to (somewhat agressively)
828 cache RT's static Javascript and CSS files.
830 This routine could really use _accurate_ heuristics. (XXX TODO)
834 sub StaticFileHeaders {
835 my $date = RT::Date->new(RT->SystemUser);
838 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
840 # remove any cookie headers -- if it is cached publicly, it
841 # shouldn't include anyone's cookie!
842 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
844 # Expire things in a month.
845 $date->Set( Value => time + 30 * 24 * 60 * 60 );
846 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
848 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
849 # request, but we don't handle it and generate full reply again
850 # Last modified at server start time
851 # $date->Set( Value => $^T );
852 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
855 =head2 ComponentPathIsSafe PATH
857 Takes C<PATH> and returns a boolean indicating that the user-specified partial
858 component path is safe.
860 Currently "safe" means that the path does not start with a dot (C<.>) and does
861 not contain a slash-dot C</.>.
865 sub ComponentPathIsSafe {
868 return $path !~ m{(?:^|/)\.};
873 Takes a C<< Path => path >> and returns a boolean indicating that
874 the path is safely within RT's control or not. The path I<must> be
877 This function does not consult the filesystem at all; it is merely
878 a logical sanity checking of the path. This explicitly does not handle
879 symlinks; if you have symlinks in RT's webroot pointing outside of it,
880 then we assume you know what you are doing.
887 my $path = $args{Path};
889 # Get File::Spec to clean up extra /s, ./, etc
890 my $cleaned_up = File::Spec->canonpath($path);
892 if (!defined($cleaned_up)) {
893 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
897 # Forbid too many ..s. We can't just sum then check because
898 # "../foo/bar/baz" should be illegal even though it has more
899 # downdirs than updirs. So as soon as we get a negative score
900 # (which means "breaking out" of the top level) we reject the path.
902 my @components = split '/', $cleaned_up;
904 for my $component (@components) {
905 if ($component eq '..') {
908 $RT::Logger->info("Rejecting unsafe path: $path");
912 elsif ($component eq '.' || $component eq '') {
913 # these two have no effect on $score
923 =head2 SendStaticFile
925 Takes a File => path and a Type => Content-type
927 If Type isn't provided and File is an image, it will
928 figure out a sane Content-type, otherwise it will
929 send application/octet-stream
931 Will set caching headers using StaticFileHeaders
938 my $file = $args{File};
939 my $type = $args{Type};
940 my $relfile = $args{RelativeFile};
942 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
943 $HTML::Mason::Commands::r->status(400);
944 $HTML::Mason::Commands::m->abort;
947 $self->StaticFileHeaders();
950 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
952 $type =~ s/jpg/jpeg/gi;
954 $type ||= "application/octet-stream";
956 $HTML::Mason::Commands::r->content_type($type);
957 open( my $fh, '<', $file ) or die "couldn't open file: $!";
961 $HTML::Mason::Commands::m->out($_) while (<$fh>);
962 $HTML::Mason::Commands::m->flush_buffer;
973 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)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
984 my $content = $args{Content};
985 return '' unless $content;
987 # Make the content have no 'weird' newlines in it
988 $content =~ s/\r+\n/\n/g;
990 my $return_content = $content;
992 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
993 my $sigonly = $args{StripSignature};
995 # massage content to easily detect if there's any real content
996 $content =~ s/\s+//g; # yes! remove all the spaces
998 # remove html version of spaces and newlines
999 $content =~ s! !!g;
1000 $content =~ s!<br/?>!!g;
1003 # Filter empty content when type is text/html
1004 return '' if $html && $content !~ /\S/;
1006 # If we aren't supposed to strip the sig, just bail now.
1007 return $return_content unless $sigonly;
1009 # Find the signature
1010 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1013 # Check for plaintext sig
1014 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1016 # Check for html-formatted sig; we don't use EscapeUTF8 here
1017 # because we want to precisely match the escapting that FCKEditor
1019 $sig =~ s/&/&/g;
1022 $sig =~ s/"/"/g;
1023 $sig =~ s/'/'/g;
1024 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1027 return $return_content;
1035 # if they've passed multiple values, they'll be an array. if they've
1036 # passed just one, a scalar whatever they are, mark them as utf8
1039 ? Encode::is_utf8($_)
1041 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1042 : ( $type eq 'ARRAY' )
1043 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1045 : ( $type eq 'HASH' )
1046 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1052 sub PreprocessTimeUpdates {
1055 # Later in the code we use
1056 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1057 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1058 # The call_next method pass through original arguments and if you have
1059 # an argument with unicode key then in a next component you'll get two
1060 # records in the args hash: one with key without UTF8 flag and another
1061 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1062 # is copied from mason's source to get the same results as we get from
1063 # call_next method, this feature is not documented, so we just leave it
1064 # here to avoid possible side effects.
1066 # This code canonicalizes time inputs in hours into minutes
1067 foreach my $field ( keys %$ARGS ) {
1068 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1070 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1071 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1072 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1073 $ARGS->{$local} *= 60;
1075 delete $ARGS->{$field};
1080 sub MaybeEnableSQLStatementLog {
1082 my $log_sql_statements = RT->Config->Get('StatementLog');
1084 if ($log_sql_statements) {
1085 $RT::Handle->ClearSQLStatementLog;
1086 $RT::Handle->LogSQLStatements(1);
1091 sub LogRecordedSQLStatements {
1094 my $log_sql_statements = RT->Config->Get('StatementLog');
1096 return unless ($log_sql_statements);
1098 my @log = $RT::Handle->SQLStatementLog;
1099 $RT::Handle->ClearSQLStatementLog;
1101 $RT::Handle->AddRequestToHistory({
1102 %{ $args{RequestData} },
1106 for my $stmt (@log) {
1107 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1117 level => $log_sql_statements,
1119 . sprintf( "%.6f", $duration )
1121 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1127 my $_has_validated_web_config = 0;
1128 sub ValidateWebConfig {
1131 # do this once per server instance, not once per request
1132 return if $_has_validated_web_config;
1133 $_has_validated_web_config = 1;
1135 if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) {
1136 $RT::Logger->warn("The actual SERVER_PORT ($ENV{SERVER_PORT}) does NOT match the configured WebPort ($RT::WebPort). Perhaps you should Set(\$WebPort, $ENV{SERVER_PORT}); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1139 if ($ENV{HTTP_HOST}) {
1140 # match "example.com" or "example.com:80"
1141 my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/;
1143 if ($host ne RT->Config->Get('WebDomain')) {
1144 $RT::Logger->warn("The actual HTTP_HOST ($host) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1148 if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) {
1149 $RT::Logger->warn("The actual SERVER_NAME ($ENV{SERVER_NAME}) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$ENV{SERVER_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1153 #i don't understand how this was ever expected to work
1154 # (even without our dum double // hack)??
1155 #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1156 ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g;
1157 ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g;
1158 my $script_name_prefix = substr($script_name, 0, length($WebPath));
1159 if ( $script_name_prefix ne $WebPath ) {
1160 $RT::Logger->warn("The actual SCRIPT_NAME ($script_name) does NOT match the configured WebPath ($WebPath). Perhaps you should Set(\$WebPath, '$script_name_prefix'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1164 sub ComponentRoots {
1166 my %args = ( Names => 0, @_ );
1168 if (defined $HTML::Mason::Commands::m) {
1169 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1172 [ local => $RT::MasonLocalComponentRoot ],
1173 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1174 [ standard => $RT::MasonComponentRoot ]
1177 @roots = map { $_->[1] } @roots unless $args{Names};
1181 our %is_whitelisted_component = (
1182 # The RSS feed embeds an auth token in the path, but query
1183 # information for the search. Because it's a straight-up read, in
1184 # addition to embedding its own auth, it's fine.
1185 '/NoAuth/rss/dhandler' => 1,
1188 sub IsCompCSRFWhitelisted {
1192 return 1 if $is_whitelisted_component{$comp};
1194 my %args = %{ $ARGS };
1196 # If the user specifies a *correct* user and pass then they are
1197 # golden. This acts on the presumption that external forms may
1198 # hardcode a username and password -- if a malicious attacker knew
1199 # both already, CSRF is the least of your problems.
1200 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1201 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1202 my $user_obj = RT::CurrentUser->new();
1203 $user_obj->Load($args{user});
1204 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1210 # Eliminate arguments that do not indicate an effectful request.
1211 # For example, "id" is acceptable because that is how RT retrieves a
1215 # If they have a valid results= from MaybeRedirectForResults, that's
1217 delete $args{results} if $args{results}
1218 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1220 # The homepage refresh, which uses the Refresh header, doesn't send
1221 # a referer in most browsers; whitelist the one parameter it reloads
1222 # with, HomeRefreshInterval, which is safe
1223 delete $args{HomeRefreshInterval};
1225 # If there are no arguments, then it's likely to be an idempotent
1226 # request, which are not susceptible to CSRF
1232 sub IsRefererCSRFWhitelisted {
1233 my $referer = _NormalizeHost(shift);
1234 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1235 $base_url = $base_url->host_port;
1238 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1239 push @$configs,$config;
1240 return 1 if $referer->host_port eq $config;
1243 return (0,$referer,$configs);
1246 =head3 _NormalizeHost
1248 Takes a URI and creates a URI object that's been normalized
1249 to handle common problems such as localhost vs 127.0.0.1
1253 sub _NormalizeHost {
1255 my $uri= URI->new(shift);
1256 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1262 sub IsPossibleCSRF {
1265 # If first request on this session is to a REST endpoint, then
1266 # whitelist the REST endpoints -- and explicitly deny non-REST
1267 # endpoints. We do this because using a REST cookie in a browser
1268 # would open the user to CSRF attacks to the REST endpoints.
1269 my $path = $HTML::Mason::Commands::r->path_info;
1270 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1271 unless defined $HTML::Mason::Commands::session{'REST'};
1273 if ($HTML::Mason::Commands::session{'REST'}) {
1274 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1276 This login session belongs to a REST client, and cannot be used to
1277 access non-REST interfaces of RT for security reasons.
1279 my $details = <<EOT;
1280 Please log out and back in to obtain a session for normal browsing. If
1281 you understand the security implications, disabling RT's CSRF protection
1282 will remove this restriction.
1285 HTML::Mason::Commands::Abort( $why, Details => $details );
1288 return 0 if IsCompCSRFWhitelisted(
1289 $HTML::Mason::Commands::m->request_comp->path,
1293 # if there is no Referer header then assume the worst
1295 "your browser did not supply a Referrer header", # loc
1296 ) if !$ENV{HTTP_REFERER};
1298 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1299 return 0 if $whitelisted;
1301 if ( @$configs > 1 ) {
1303 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1304 $browser->host_port,
1306 join(', ', @$configs) );
1310 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1311 $browser->host_port,
1315 sub ExpandCSRFToken {
1318 my $token = delete $ARGS->{CSRF_Token};
1319 return unless $token;
1321 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1322 return unless $data;
1323 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1325 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1326 return unless $user->ValidateAuthString( $data->{auth}, $token );
1328 %{$ARGS} = %{$data->{args}};
1329 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1331 # We explicitly stored file attachments with the request, but not in
1332 # the session yet, as that would itself be an attack. Put them into
1333 # the session now, so they'll be visible.
1334 if ($data->{attach}) {
1335 my $filename = $data->{attach}{filename};
1336 my $mime = $data->{attach}{mime};
1337 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1344 sub StoreRequestToken {
1347 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1348 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1350 auth => $user->GenerateAuthString( $token ),
1351 path => $HTML::Mason::Commands::r->path_info,
1354 if ($ARGS->{Attach}) {
1355 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1356 my $file_path = delete $ARGS->{'Attach'};
1358 filename => Encode::decode_utf8("$file_path"),
1359 mime => $attachment,
1363 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1364 $HTML::Mason::Commands::session{'i'}++;
1368 sub MaybeShowInterstitialCSRFPage {
1371 return unless RT->Config->Get('RestrictReferrer');
1373 # Deal with the form token provided by the interstitial, which lets
1374 # browsers which never set referer headers still use RT, if
1375 # painfully. This blows values into ARGS
1376 return if ExpandCSRFToken($ARGS);
1378 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1379 return if !$is_csrf;
1381 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1383 my $token = StoreRequestToken($ARGS);
1384 $HTML::Mason::Commands::m->comp(
1386 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1387 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1390 # Calls abort, never gets here
1393 package HTML::Mason::Commands;
1395 use vars qw/$r $m %session/;
1398 return $HTML::Mason::Commands::m->notes('menu');
1402 return $HTML::Mason::Commands::m->notes('page-menu');
1406 return $HTML::Mason::Commands::m->notes('page-widgets');
1413 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1414 with whatever it's called with. If there is no $session{'CurrentUser'},
1415 it creates a temporary user, so we have something to get a localisation handle
1422 if ( $session{'CurrentUser'}
1423 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1425 return ( $session{'CurrentUser'}->loc(@_) );
1428 RT::CurrentUser->new();
1432 return ( $u->loc(@_) );
1435 # pathetic case -- SystemUser is gone.
1442 =head2 loc_fuzzy STRING
1444 loc_fuzzy is for handling localizations of messages that may already
1445 contain interpolated variables, typically returned from libraries
1446 outside RT's control. It takes the message string and extracts the
1447 variable array automatically by matching against the candidate entries
1448 inside the lexicon file.
1455 if ( $session{'CurrentUser'}
1456 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1458 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1460 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1461 return ( $u->loc_fuzzy($msg) );
1466 # Error - calls Error and aborts
1471 if ( $session{'ErrorDocument'}
1472 && $session{'ErrorDocumentType'} )
1474 $r->content_type( $session{'ErrorDocumentType'} );
1475 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1478 $m->comp( "/Elements/Error", Why => $why, %args );
1483 sub MaybeRedirectForResults {
1485 Path => $HTML::Mason::Commands::m->request_comp->path,
1492 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1493 return unless $has_actions || $args{'Force'};
1495 my %arguments = %{ $args{'Arguments'} };
1497 if ( $has_actions ) {
1498 my $key = Digest::MD5::md5_hex( rand(1024) );
1499 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1501 $arguments{'results'} = $key;
1504 $args{'Path'} =~ s!^/+!!;
1505 my $url = RT->Config->Get('WebURL') . $args{Path};
1507 if ( keys %arguments ) {
1508 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1510 if ( $args{'Anchor'} ) {
1511 $url .= "#". $args{'Anchor'};
1513 return RT::Interface::Web::Redirect($url);
1516 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1518 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1519 redirect to the approvals display page, preserving any arguments.
1521 C<Path>s matching C<Whitelist> are let through.
1523 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1527 sub MaybeRedirectToApproval {
1529 Path => $HTML::Mason::Commands::m->request_comp->path,
1535 return unless $ENV{REQUEST_METHOD} eq 'GET';
1537 my $id = $args{ARGSRef}->{id};
1540 and RT->Config->Get('ForceApprovalsView')
1541 and not $args{Path} =~ /$args{Whitelist}/)
1543 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1546 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1547 MaybeRedirectForResults(
1548 Path => "/Approvals/Display.html",
1550 Anchor => $args{ARGSRef}->{Anchor},
1551 Arguments => $args{ARGSRef},
1557 =head2 CreateTicket ARGS
1559 Create a new ticket, using Mason's %ARGS. returns @results.
1568 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1570 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1571 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1572 Abort('Queue not found');
1575 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1576 Abort('You have no permission to create tickets in that queue.');
1580 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1581 $due = RT::Date->new( $session{'CurrentUser'} );
1582 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1585 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1586 $starts = RT::Date->new( $session{'CurrentUser'} );
1587 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1590 my $sigless = RT::Interface::Web::StripContent(
1591 Content => $ARGS{Content},
1592 ContentType => $ARGS{ContentType},
1593 StripSignature => 1,
1594 CurrentUser => $session{'CurrentUser'},
1597 my $MIMEObj = MakeMIMEEntity(
1598 Subject => $ARGS{'Subject'},
1599 From => $ARGS{'From'},
1602 Type => $ARGS{'ContentType'},
1605 if ( $ARGS{'Attachments'} ) {
1606 my $rv = $MIMEObj->make_multipart;
1607 $RT::Logger->error("Couldn't make multipart message")
1608 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1610 foreach ( values %{ $ARGS{'Attachments'} } ) {
1612 $RT::Logger->error("Couldn't add empty attachemnt");
1615 $MIMEObj->add_part($_);
1619 foreach my $argument (qw(Encrypt Sign)) {
1620 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1621 if defined $ARGS{$argument};
1625 Type => $ARGS{'Type'} || 'ticket',
1626 Queue => $ARGS{'Queue'},
1627 Owner => $ARGS{'Owner'},
1630 Requestor => $ARGS{'Requestors'},
1632 AdminCc => $ARGS{'AdminCc'},
1633 InitialPriority => $ARGS{'InitialPriority'},
1634 FinalPriority => $ARGS{'FinalPriority'},
1635 TimeLeft => $ARGS{'TimeLeft'},
1636 TimeEstimated => $ARGS{'TimeEstimated'},
1637 TimeWorked => $ARGS{'TimeWorked'},
1638 Subject => $ARGS{'Subject'},
1639 Status => $ARGS{'Status'},
1640 Due => $due ? $due->ISO : undef,
1641 Starts => $starts ? $starts->ISO : undef,
1646 foreach my $type (qw(Requestor Cc AdminCc)) {
1647 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1648 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1650 $create_args{TransSquelchMailTo} = \@txn_squelch
1653 if ( $ARGS{'AttachTickets'} ) {
1654 require RT::Action::SendEmail;
1655 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1656 ref $ARGS{'AttachTickets'}
1657 ? @{ $ARGS{'AttachTickets'} }
1658 : ( $ARGS{'AttachTickets'} ) );
1661 foreach my $arg ( keys %ARGS ) {
1662 next if $arg =~ /-(?:Magic|Category)$/;
1664 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1665 $create_args{$arg} = $ARGS{$arg};
1668 # Object-RT::Ticket--CustomField-3-Values
1669 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1672 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1673 $cf->SetContextObject( $Queue );
1675 unless ( $cf->id ) {
1676 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1680 if ( $arg =~ /-Upload$/ ) {
1681 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1685 my $type = $cf->Type;
1688 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1689 @values = @{ $ARGS{$arg} };
1690 } elsif ( $type =~ /text/i ) {
1691 @values = ( $ARGS{$arg} );
1693 no warnings 'uninitialized';
1694 @values = split /\r*\n/, $ARGS{$arg};
1696 @values = grep length, map {
1702 grep defined, @values;
1704 $create_args{"CustomField-$cfid"} = \@values;
1708 # turn new link lists into arrays, and pass in the proper arguments
1710 'new-DependsOn' => 'DependsOn',
1711 'DependsOn-new' => 'DependedOnBy',
1712 'new-MemberOf' => 'Parents',
1713 'MemberOf-new' => 'Children',
1714 'new-RefersTo' => 'RefersTo',
1715 'RefersTo-new' => 'ReferredToBy',
1717 foreach my $key ( keys %map ) {
1718 next unless $ARGS{$key};
1719 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1723 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1728 push( @Actions, split( "\n", $ErrMsg ) );
1729 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1730 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1732 return ( $Ticket, @Actions );
1738 =head2 LoadTicket id
1740 Takes a ticket id as its only variable. if it's handed an array, it takes
1743 Returns an RT::Ticket object as the current user.
1750 if ( ref($id) eq "ARRAY" ) {
1755 Abort("No ticket specified");
1758 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1760 unless ( $Ticket->id ) {
1761 Abort("Could not load ticket $id");
1768 =head2 ProcessUpdateMessage
1770 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1772 Don't write message if it only contains current user's signature and
1773 SkipSignatureOnly argument is true. Function anyway adds attachments
1774 and updates time worked field even if skips message. The default value
1779 sub ProcessUpdateMessage {
1784 SkipSignatureOnly => 1,
1788 if ( $args{ARGSRef}->{'UpdateAttachments'}
1789 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1791 delete $args{ARGSRef}->{'UpdateAttachments'};
1794 # Strip the signature
1795 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1796 Content => $args{ARGSRef}->{UpdateContent},
1797 ContentType => $args{ARGSRef}->{UpdateContentType},
1798 StripSignature => $args{SkipSignatureOnly},
1799 CurrentUser => $args{'TicketObj'}->CurrentUser,
1802 # If, after stripping the signature, we have no message, move the
1803 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1804 # ProcessBasics can deal -- then bail out.
1805 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1806 and not length $args{ARGSRef}->{'UpdateContent'} )
1808 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1809 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1814 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1815 $args{ARGSRef}->{'UpdateSubject'} = undef;
1818 my $Message = MakeMIMEEntity(
1819 Subject => $args{ARGSRef}->{'UpdateSubject'},
1820 Body => $args{ARGSRef}->{'UpdateContent'},
1821 Type => $args{ARGSRef}->{'UpdateContentType'},
1824 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1825 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1827 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1828 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1829 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1831 $old_txn = $args{TicketObj}->Transactions->First();
1834 if ( my $msg = $old_txn->Message->First ) {
1835 RT::Interface::Email::SetInReplyTo(
1836 Message => $Message,
1841 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1842 $Message->make_multipart;
1843 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1846 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1847 require RT::Action::SendEmail;
1848 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1849 ref $args{ARGSRef}->{'AttachTickets'}
1850 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1851 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1854 my %txn_customfields;
1856 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1857 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1858 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1862 my %message_args = (
1863 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1864 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1865 MIMEObj => $Message,
1866 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1867 CustomFields => \%txn_customfields,
1870 _ProcessUpdateMessageRecipients(
1871 MessageArgs => \%message_args,
1876 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1877 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1878 push( @results, $Description );
1879 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1880 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1881 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1882 push( @results, $Description );
1883 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1886 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1891 sub _ProcessUpdateMessageRecipients {
1895 MessageArgs => undef,
1899 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1900 my $cc = $args{ARGSRef}->{'UpdateCc'};
1902 my $message_args = $args{MessageArgs};
1904 $message_args->{CcMessageTo} = $cc;
1905 $message_args->{BccMessageTo} = $bcc;
1908 foreach my $type (qw(Cc AdminCc)) {
1909 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1910 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1911 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1912 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1915 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1916 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1917 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1921 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1922 $message_args->{SquelchMailTo} = \@txn_squelch
1925 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1926 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1927 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1929 my $var = ucfirst($1) . 'MessageTo';
1931 if ( $message_args->{$var} ) {
1932 $message_args->{$var} .= ", $value";
1934 $message_args->{$var} = $value;
1940 =head2 MakeMIMEEntity PARAMHASH
1942 Takes a paramhash Subject, Body and AttachmentFieldName.
1944 Also takes Form, Cc and Type as optional paramhash keys.
1946 Returns a MIME::Entity.
1950 sub MakeMIMEEntity {
1952 #TODO document what else this takes.
1958 AttachmentFieldName => undef,
1962 my $Message = MIME::Entity->build(
1963 Type => 'multipart/mixed',
1964 "Message-Id" => RT::Interface::Email::GenMessageId,
1965 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1966 grep defined $args{$_}, qw(Subject From Cc)
1969 if ( defined $args{'Body'} && length $args{'Body'} ) {
1971 # Make the update content have no 'weird' newlines in it
1972 $args{'Body'} =~ s/\r\n/\n/gs;
1975 Type => $args{'Type'} || 'text/plain',
1977 Data => $args{'Body'},
1981 if ( $args{'AttachmentFieldName'} ) {
1983 my $cgi_object = $m->cgi_object;
1984 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1985 if ( defined $filehandle && length $filehandle ) {
1987 my ( @content, $buffer );
1988 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1989 push @content, $buffer;
1992 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1994 my $filename = "$filehandle";
1995 $filename =~ s{^.*[\\/]}{};
1998 Type => $uploadinfo->{'Content-Type'},
1999 Filename => $filename,
2002 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2003 $Message->head->set( 'Subject' => $filename );
2006 # Attachment parts really shouldn't get a Message-ID
2007 $Message->head->delete('Message-ID');
2011 $Message->make_singlepart;
2013 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2021 =head2 ParseDateToISO
2023 Takes a date in an arbitrary format.
2024 Returns an ISO date and time in GMT
2028 sub ParseDateToISO {
2031 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2033 Format => 'unknown',
2036 return ( $date_obj->ISO );
2041 sub ProcessACLChanges {
2042 my $ARGSref = shift;
2046 foreach my $arg ( keys %$ARGSref ) {
2047 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2049 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2052 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2053 @rights = @{ $ARGSref->{$arg} };
2055 @rights = $ARGSref->{$arg};
2057 @rights = grep $_, @rights;
2058 next unless @rights;
2060 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2061 $principal->Load($principal_id);
2064 if ( $object_type eq 'RT::System' ) {
2066 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2067 $obj = $object_type->new( $session{'CurrentUser'} );
2068 $obj->Load($object_id);
2069 unless ( $obj->id ) {
2070 $RT::Logger->error("couldn't load $object_type #$object_id");
2074 $RT::Logger->error("object type '$object_type' is incorrect");
2075 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2079 foreach my $right (@rights) {
2080 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2081 push( @results, $msg );
2091 ProcessACLs expects values from a series of checkboxes that describe the full
2092 set of rights a principal should have on an object.
2094 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2095 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2096 listing the rights the principal should have, and ProcessACLs will modify the
2097 current rights to match. Additionally, the previously unused CheckACL input
2098 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2099 rights are removed from a principal and as such no SetRights input is
2105 my $ARGSref = shift;
2106 my (%state, @results);
2108 my $CheckACL = $ARGSref->{'CheckACL'};
2109 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2111 # Check if we want to grant rights to a previously rights-less user
2112 for my $type (qw(user group)) {
2113 my $key = "AddPrincipalForRights-$type";
2115 next unless $ARGSref->{$key};
2118 if ( $type eq 'user' ) {
2119 $principal = RT::User->new( $session{'CurrentUser'} );
2120 $principal->LoadByCol( Name => $ARGSref->{$key} );
2123 $principal = RT::Group->new( $session{'CurrentUser'} );
2124 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2127 unless ($principal->PrincipalId) {
2128 push @results, loc("Couldn't load the specified principal");
2132 my $principal_id = $principal->PrincipalId;
2134 # Turn our addprincipal rights spec into a real one
2135 for my $arg (keys %$ARGSref) {
2136 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2138 my $tuple = "$principal_id-$1";
2139 my $key = "SetRights-$tuple";
2141 # If we have it already, that's odd, but merge them
2142 if (grep { $_ eq $tuple } @check) {
2143 $ARGSref->{$key} = [
2144 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2145 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2148 $ARGSref->{$key} = $ARGSref->{$arg};
2149 push @check, $tuple;
2154 # Build our rights state for each Principal-Object tuple
2155 foreach my $arg ( keys %$ARGSref ) {
2156 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2159 my $value = $ARGSref->{$arg};
2160 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2161 next unless @rights;
2163 $state{$tuple} = { map { $_ => 1 } @rights };
2166 foreach my $tuple (List::MoreUtils::uniq @check) {
2167 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2169 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2171 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2172 $principal->Load($principal_id);
2175 if ( $object_type eq 'RT::System' ) {
2177 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2178 $obj = $object_type->new( $session{'CurrentUser'} );
2179 $obj->Load($object_id);
2180 unless ( $obj->id ) {
2181 $RT::Logger->error("couldn't load $object_type #$object_id");
2185 $RT::Logger->error("object type '$object_type' is incorrect");
2186 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2190 my $acls = RT::ACL->new($session{'CurrentUser'});
2191 $acls->LimitToObject( $obj );
2192 $acls->LimitToPrincipal( Id => $principal_id );
2194 while ( my $ace = $acls->Next ) {
2195 my $right = $ace->RightName;
2197 # Has right and should have right
2198 next if delete $state{$tuple}->{$right};
2200 # Has right and shouldn't have right
2201 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2202 push @results, $msg;
2205 # For everything left, they don't have the right but they should
2206 for my $right (keys %{ $state{$tuple} || {} }) {
2207 delete $state{$tuple}->{$right};
2208 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2209 push @results, $msg;
2212 # Check our state for leftovers
2213 if ( keys %{ $state{$tuple} || {} } ) {
2214 my $missed = join '|', %{$state{$tuple} || {}};
2216 "Uh-oh, it looks like we somehow missed a right in "
2217 ."ProcessACLs. Here's what was leftover: $missed"
2228 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2230 @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.
2232 Returns an array of success/failure messages
2236 sub UpdateRecordObject {
2239 AttributesRef => undef,
2241 AttributePrefix => undef,
2245 my $Object = $args{'Object'};
2246 my @results = $Object->Update(
2247 AttributesRef => $args{'AttributesRef'},
2248 ARGSRef => $args{'ARGSRef'},
2249 AttributePrefix => $args{'AttributePrefix'},
2257 sub ProcessCustomFieldUpdates {
2259 CustomFieldObj => undef,
2264 my $Object = $args{'CustomFieldObj'};
2265 my $ARGSRef = $args{'ARGSRef'};
2267 my @attribs = qw(Name Type Description Queue SortOrder);
2268 my @results = UpdateRecordObject(
2269 AttributesRef => \@attribs,
2274 my $prefix = "CustomField-" . $Object->Id;
2275 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2276 my ( $addval, $addmsg ) = $Object->AddValue(
2277 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2278 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2279 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2281 push( @results, $addmsg );
2285 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2286 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2287 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2289 foreach my $id (@delete_values) {
2290 next unless defined $id;
2291 my ( $err, $msg ) = $Object->DeleteValue($id);
2292 push( @results, $msg );
2295 my $vals = $Object->Values();
2296 while ( my $cfv = $vals->Next() ) {
2297 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2298 if ( $cfv->SortOrder != $so ) {
2299 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2300 push( @results, $msg );
2310 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2312 Returns an array of results messages.
2316 sub ProcessTicketBasics {
2324 my $TicketObj = $args{'TicketObj'};
2325 my $ARGSRef = $args{'ARGSRef'};
2327 my $OrigOwner = $TicketObj->Owner;
2342 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2343 for my $field (qw(Queue Owner)) {
2344 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2345 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2346 my $temp = $class->new(RT->SystemUser);
2347 $temp->Load( $ARGSRef->{$field} );
2349 $ARGSRef->{$field} = $temp->id;
2354 # Status isn't a field that can be set to a null value.
2355 # RT core complains if you try
2356 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2358 my @results = UpdateRecordObject(
2359 AttributesRef => \@attribs,
2360 Object => $TicketObj,
2361 ARGSRef => $ARGSRef,
2364 # We special case owner changing, so we can use ForceOwnerChange
2365 if ( $ARGSRef->{'Owner'}
2366 && $ARGSRef->{'Owner'} !~ /\D/
2367 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2369 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2370 $ChownType = "Force";
2376 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2377 push( @results, $msg );
2385 sub ProcessTicketReminders {
2392 my $Ticket = $args{'TicketObj'};
2393 my $args = $args{'ARGSRef'};
2396 my $reminder_collection = $Ticket->Reminders->Collection;
2398 if ( $args->{'update-reminders'} ) {
2399 while ( my $reminder = $reminder_collection->Next ) {
2400 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2401 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2402 $Ticket->Reminders->Resolve($reminder);
2404 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2405 $Ticket->Reminders->Open($reminder);
2408 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2409 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2412 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2413 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2416 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2417 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2419 Format => 'unknown',
2420 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2422 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2423 $reminder->SetDue( $DateObj->ISO );
2429 if ( $args->{'NewReminder-Subject'} ) {
2430 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2432 Format => 'unknown',
2433 Value => $args->{'NewReminder-Due'}
2435 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2436 Subject => $args->{'NewReminder-Subject'},
2437 Owner => $args->{'NewReminder-Owner'},
2438 Due => $due_obj->ISO
2440 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2445 sub ProcessTicketCustomFieldUpdates {
2447 $args{'Object'} = delete $args{'TicketObj'};
2448 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2450 # Build up a list of objects that we want to work with
2451 my %custom_fields_to_mod;
2452 foreach my $arg ( keys %$ARGSRef ) {
2453 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2454 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2455 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2456 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2457 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2458 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2462 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2465 sub ProcessObjectCustomFieldUpdates {
2467 my $ARGSRef = $args{'ARGSRef'};
2470 # Build up a list of objects that we want to work with
2471 my %custom_fields_to_mod;
2472 foreach my $arg ( keys %$ARGSRef ) {
2474 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2475 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2477 # For each of those objects, find out what custom fields we want to work with.
2478 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2481 # For each of those objects
2482 foreach my $class ( keys %custom_fields_to_mod ) {
2483 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2484 my $Object = $args{'Object'};
2485 $Object = $class->new( $session{'CurrentUser'} )
2486 unless $Object && ref $Object eq $class;
2488 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2489 unless ( $Object->id ) {
2490 $RT::Logger->warning("Couldn't load object $class #$id");
2494 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2495 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2496 $CustomFieldObj->SetContextObject($Object);
2497 $CustomFieldObj->LoadById($cf);
2498 unless ( $CustomFieldObj->id ) {
2499 $RT::Logger->warning("Couldn't load custom field #$cf");
2503 _ProcessObjectCustomFieldUpdates(
2504 Prefix => "Object-$class-$id-CustomField-$cf-",
2506 CustomField => $CustomFieldObj,
2507 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2515 sub _ProcessObjectCustomFieldUpdates {
2517 my $cf = $args{'CustomField'};
2518 my $cf_type = $cf->Type || '';
2520 # Remove blank Values since the magic field will take care of this. Sometimes
2521 # the browser gives you a blank value which causes CFs to be processed twice
2522 if ( defined $args{'ARGS'}->{'Values'}
2523 && !length $args{'ARGS'}->{'Values'}
2524 && $args{'ARGS'}->{'Values-Magic'} )
2526 delete $args{'ARGS'}->{'Values'};
2530 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2532 # skip category argument
2533 next if $arg eq 'Category';
2536 next if $arg eq 'Value-TimeUnits';
2538 # since http won't pass in a form element with a null value, we need
2540 if ( $arg eq 'Values-Magic' ) {
2542 # We don't care about the magic, if there's really a values element;
2543 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2544 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2546 # "Empty" values does not mean anything for Image and Binary fields
2547 next if $cf_type =~ /^(?:Image|Binary)$/;
2550 $args{'ARGS'}->{'Values'} = undef;
2554 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2555 @values = @{ $args{'ARGS'}->{$arg} };
2556 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2557 @values = ( $args{'ARGS'}->{$arg} );
2559 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2560 if defined $args{'ARGS'}->{$arg};
2562 @values = grep length, map {
2568 grep defined, @values;
2570 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2571 foreach my $value (@values) {
2572 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2576 push( @results, $msg );
2578 } elsif ( $arg eq 'Upload' ) {
2579 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2580 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2581 push( @results, $msg );
2582 } elsif ( $arg eq 'DeleteValues' ) {
2583 foreach my $value (@values) {
2584 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2588 push( @results, $msg );
2590 } elsif ( $arg eq 'DeleteValueIds' ) {
2591 foreach my $value (@values) {
2592 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2596 push( @results, $msg );
2598 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2599 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2602 foreach my $value (@values) {
2603 if ( my $entry = $cf_values->HasEntry($value) ) {
2604 $values_hash{ $entry->id } = 1;
2608 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2612 push( @results, $msg );
2613 $values_hash{$val} = 1 if $val;
2616 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2617 return @results if ( $cf->Type eq 'Date' && ! @values );
2619 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2620 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2622 $cf_values->RedoSearch;
2623 while ( my $cf_value = $cf_values->Next ) {
2624 next if $values_hash{ $cf_value->id };
2626 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2628 ValueId => $cf_value->id
2630 push( @results, $msg );
2632 } elsif ( $arg eq 'Values' ) {
2633 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2635 # keep everything up to the point of difference, delete the rest
2637 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2638 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2647 # now add/replace extra things, if any
2648 foreach my $value (@values) {
2649 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2653 push( @results, $msg );
2658 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2659 $cf->Name, ref $args{'Object'},
2669 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2671 Returns an array of results messages.
2675 sub ProcessTicketWatchers {
2683 my $Ticket = $args{'TicketObj'};
2684 my $ARGSRef = $args{'ARGSRef'};
2688 foreach my $key ( keys %$ARGSRef ) {
2690 # Delete deletable watchers
2691 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2692 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2696 push @results, $msg;
2699 # Delete watchers in the simple style demanded by the bulk manipulator
2700 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2701 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2702 Email => $ARGSRef->{$key},
2705 push @results, $msg;
2708 # Add new wathchers by email address
2709 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2710 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2713 #They're in this order because otherwise $1 gets clobbered :/
2714 my ( $code, $msg ) = $Ticket->AddWatcher(
2715 Type => $ARGSRef->{$key},
2716 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2718 push @results, $msg;
2721 #Add requestors in the simple style demanded by the bulk manipulator
2722 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2723 my ( $code, $msg ) = $Ticket->AddWatcher(
2725 Email => $ARGSRef->{$key}
2727 push @results, $msg;
2730 # Add new watchers by owner
2731 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2732 my $principal_id = $1;
2733 my $form = $ARGSRef->{$key};
2734 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2735 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2737 my ( $code, $msg ) = $Ticket->AddWatcher(
2739 PrincipalId => $principal_id
2741 push @results, $msg;
2751 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2753 Returns an array of results messages.
2757 sub ProcessTicketDates {
2764 my $Ticket = $args{'TicketObj'};
2765 my $ARGSRef = $args{'ARGSRef'};
2770 my @date_fields = qw(
2778 #Run through each field in this list. update the value if apropriate
2779 foreach my $field (@date_fields) {
2780 next unless exists $ARGSRef->{ $field . '_Date' };
2781 next if $ARGSRef->{ $field . '_Date' } eq '';
2785 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2787 Format => 'unknown',
2788 Value => $ARGSRef->{ $field . '_Date' }
2791 my $obj = $field . "Obj";
2792 if ( ( defined $DateObj->Unix )
2793 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2795 my $method = "Set$field";
2796 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2797 push @results, "$msg";
2807 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2809 Returns an array of results messages.
2813 sub ProcessTicketLinks {
2820 my $Ticket = $args{'TicketObj'};
2821 my $ARGSRef = $args{'ARGSRef'};
2823 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2825 #Merge if we need to
2826 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2827 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2828 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2829 push @results, $msg;
2836 sub ProcessRecordLinks {
2843 my $Record = $args{'RecordObj'};
2844 my $ARGSRef = $args{'ARGSRef'};
2848 # Delete links that are gone gone gone.
2849 foreach my $arg ( keys %$ARGSRef ) {
2850 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2855 my ( $val, $msg ) = $Record->DeleteLink(
2861 push @results, $msg;
2867 my @linktypes = qw( DependsOn MemberOf RefersTo );
2869 foreach my $linktype (@linktypes) {
2870 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2871 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2872 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2874 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2876 $luri =~ s/\s+$//; # Strip trailing whitespace
2877 my ( $val, $msg ) = $Record->AddLink(
2881 push @results, $msg;
2884 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2885 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2886 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2888 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2890 my ( $val, $msg ) = $Record->AddLink(
2895 push @results, $msg;
2903 =head2 _UploadedFile ( $arg );
2905 Takes a CGI parameter name; if a file is uploaded under that name,
2906 return a hash reference suitable for AddCustomFieldValue's use:
2907 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2909 Returns C<undef> if no files were uploaded in the C<$arg> field.
2915 my $cgi_object = $m->cgi_object;
2916 my $fh = $cgi_object->upload($arg) or return undef;
2917 my $upload_info = $cgi_object->uploadInfo($fh);
2919 my $filename = "$fh";
2920 $filename =~ s#^.*[\\/]##;
2925 LargeContent => do { local $/; scalar <$fh> },
2926 ContentType => $upload_info->{'Content-Type'},
2930 sub GetColumnMapEntry {
2931 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2933 # deal with the simplest thing first
2934 if ( $args{'Map'}{ $args{'Name'} } ) {
2935 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2939 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2940 return undef unless $args{'Map'}->{$mainkey};
2941 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2942 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2944 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2949 sub ProcessColumnMapValue {
2951 my %args = ( Arguments => [], Escape => 1, @_ );
2954 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2955 my @tmp = $value->( @{ $args{'Arguments'} } );
2956 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2957 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2958 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2959 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2964 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2968 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2970 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2971 principal collections mapped from the categories given.
2975 sub GetPrincipalsMap {
2980 my $system = RT::Groups->new($session{'CurrentUser'});
2981 $system->LimitToSystemInternalGroups();
2982 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2984 'System' => $system, # loc_left_pair
2989 my $groups = RT::Groups->new($session{'CurrentUser'});
2990 $groups->LimitToUserDefinedGroups();
2991 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2993 # Only show groups who have rights granted on this object
2994 $groups->WithGroupRight(
2997 IncludeSystemRights => 0,
2998 IncludeSubgroupMembers => 0,
3002 'User Groups' => $groups, # loc_left_pair
3007 my $roles = RT::Groups->new($session{'CurrentUser'});
3009 if ($object->isa('RT::System')) {
3010 $roles->LimitToRolesForSystem();
3012 elsif ($object->isa('RT::Queue')) {
3013 $roles->LimitToRolesForQueue($object->Id);
3016 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3019 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3021 'Roles' => $roles, # loc_left_pair
3026 my $Users = RT->PrivilegedUsers->UserMembersObj();
3027 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3029 # Only show users who have rights granted on this object
3030 my $group_members = $Users->WhoHaveGroupRight(
3033 IncludeSystemRights => 0,
3034 IncludeSubgroupMembers => 0,
3037 # Limit to UserEquiv groups
3038 my $groups = $Users->NewAlias('Groups');
3042 ALIAS2 => $group_members,
3045 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3046 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3050 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3053 'Users' => $Users, # loc_left_pair
3061 =head2 _load_container_object ( $type, $id );
3063 Instantiate container object for saving searches.
3067 sub _load_container_object {
3068 my ( $obj_type, $obj_id ) = @_;
3069 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3072 =head2 _parse_saved_search ( $arg );
3074 Given a serialization string for saved search, and returns the
3075 container object and the search id.
3079 sub _parse_saved_search {
3081 return unless $spec;
3082 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3089 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3092 =head2 ScrubHTML content
3094 Removes unsafe and undesired HTML from the passed content
3100 my $Content = shift;
3101 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3103 $Content = '' if !defined($Content);
3104 return $SCRUBBER->scrub($Content);
3109 Returns a new L<HTML::Scrubber> object.
3111 If you need to be more lax about what HTML tags and attributes are allowed,
3112 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3115 package HTML::Mason::Commands;
3116 # Let tables through
3117 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3122 our @SCRUBBER_ALLOWED_TAGS = qw(
3123 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3124 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3127 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3128 # Match http, ftp and relative urls
3129 # XXX: we also scrub format strings with this module then allow simple config options
3130 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3136 (?:(?:background-)?color: \s*
3137 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3138 \#[a-f0-9]{3,6} | # #fff or #ffffff
3139 [\w\-]+ # green, light-blue, etc.
3141 text-align: \s* \w+ |
3142 font-size: \s* [\w.\-]+ |
3143 font-family: \s* [\w\s"',.\-]+ |
3144 font-weight: \s* [\w\-]+ |
3146 # MS Office styles, which are probably fine. If we don't, then any
3147 # associated styles in the same attribute get stripped.
3148 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3150 +$ # one or more of these allowed properties from here 'till sunset
3152 dir => qr/^(rtl|ltr)$/i,
3153 lang => qr/^\w+(-\w+)?$/,
3156 our %SCRUBBER_RULES = ();
3159 require HTML::Scrubber;
3160 my $scrubber = HTML::Scrubber->new();
3164 %SCRUBBER_ALLOWED_ATTRIBUTES,
3165 '*' => 0, # require attributes be explicitly allowed
3168 $scrubber->deny(qw[*]);
3169 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3170 $scrubber->rules(%SCRUBBER_RULES);
3172 # Scrubbing comments is vital since IE conditional comments can contain
3173 # arbitrary HTML and we'd pass it right on through.
3174 $scrubber->comment(0);
3181 Redispatches to L<RT::Interface::Web/EncodeJSON>
3186 RT::Interface::Web::EncodeJSON(@_);
3189 package RT::Interface::Web;
3190 RT::Base->_ImportOverlays();