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 $s = "http://$s" unless $s =~ /^http/i;
1256 my $uri= URI->new($s);
1257 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1263 sub IsPossibleCSRF {
1266 # If first request on this session is to a REST endpoint, then
1267 # whitelist the REST endpoints -- and explicitly deny non-REST
1268 # endpoints. We do this because using a REST cookie in a browser
1269 # would open the user to CSRF attacks to the REST endpoints.
1270 my $path = $HTML::Mason::Commands::r->path_info;
1271 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1272 unless defined $HTML::Mason::Commands::session{'REST'};
1274 if ($HTML::Mason::Commands::session{'REST'}) {
1275 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1277 This login session belongs to a REST client, and cannot be used to
1278 access non-REST interfaces of RT for security reasons.
1280 my $details = <<EOT;
1281 Please log out and back in to obtain a session for normal browsing. If
1282 you understand the security implications, disabling RT's CSRF protection
1283 will remove this restriction.
1286 HTML::Mason::Commands::Abort( $why, Details => $details );
1289 return 0 if IsCompCSRFWhitelisted(
1290 $HTML::Mason::Commands::m->request_comp->path,
1294 # if there is no Referer header then assume the worst
1296 "your browser did not supply a Referrer header", # loc
1297 ) if !$ENV{HTTP_REFERER};
1299 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1300 return 0 if $whitelisted;
1302 if ( @$configs > 1 ) {
1304 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1305 $browser->host_port,
1307 join(', ', @$configs) );
1311 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1312 $browser->host_port,
1316 sub ExpandCSRFToken {
1319 my $token = delete $ARGS->{CSRF_Token};
1320 return unless $token;
1322 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1323 return unless $data;
1324 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1326 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1327 return unless $user->ValidateAuthString( $data->{auth}, $token );
1329 %{$ARGS} = %{$data->{args}};
1330 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1332 # We explicitly stored file attachments with the request, but not in
1333 # the session yet, as that would itself be an attack. Put them into
1334 # the session now, so they'll be visible.
1335 if ($data->{attach}) {
1336 my $filename = $data->{attach}{filename};
1337 my $mime = $data->{attach}{mime};
1338 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1345 sub StoreRequestToken {
1348 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1349 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1351 auth => $user->GenerateAuthString( $token ),
1352 path => $HTML::Mason::Commands::r->path_info,
1355 if ($ARGS->{Attach}) {
1356 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1357 my $file_path = delete $ARGS->{'Attach'};
1359 filename => Encode::decode_utf8("$file_path"),
1360 mime => $attachment,
1364 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1365 $HTML::Mason::Commands::session{'i'}++;
1369 sub MaybeShowInterstitialCSRFPage {
1372 return unless RT->Config->Get('RestrictReferrer');
1374 # Deal with the form token provided by the interstitial, which lets
1375 # browsers which never set referer headers still use RT, if
1376 # painfully. This blows values into ARGS
1377 return if ExpandCSRFToken($ARGS);
1379 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1380 return if !$is_csrf;
1382 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1384 my $token = StoreRequestToken($ARGS);
1385 $HTML::Mason::Commands::m->comp(
1387 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1388 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1391 # Calls abort, never gets here
1394 package HTML::Mason::Commands;
1396 use vars qw/$r $m %session/;
1399 return $HTML::Mason::Commands::m->notes('menu');
1403 return $HTML::Mason::Commands::m->notes('page-menu');
1407 return $HTML::Mason::Commands::m->notes('page-widgets');
1414 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1415 with whatever it's called with. If there is no $session{'CurrentUser'},
1416 it creates a temporary user, so we have something to get a localisation handle
1423 if ( $session{'CurrentUser'}
1424 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1426 return ( $session{'CurrentUser'}->loc(@_) );
1429 RT::CurrentUser->new();
1433 return ( $u->loc(@_) );
1436 # pathetic case -- SystemUser is gone.
1443 =head2 loc_fuzzy STRING
1445 loc_fuzzy is for handling localizations of messages that may already
1446 contain interpolated variables, typically returned from libraries
1447 outside RT's control. It takes the message string and extracts the
1448 variable array automatically by matching against the candidate entries
1449 inside the lexicon file.
1456 if ( $session{'CurrentUser'}
1457 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1459 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1461 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1462 return ( $u->loc_fuzzy($msg) );
1467 # Error - calls Error and aborts
1472 if ( $session{'ErrorDocument'}
1473 && $session{'ErrorDocumentType'} )
1475 $r->content_type( $session{'ErrorDocumentType'} );
1476 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1479 $m->comp( "/Elements/Error", Why => $why, %args );
1484 sub MaybeRedirectForResults {
1486 Path => $HTML::Mason::Commands::m->request_comp->path,
1493 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1494 return unless $has_actions || $args{'Force'};
1496 my %arguments = %{ $args{'Arguments'} };
1498 if ( $has_actions ) {
1499 my $key = Digest::MD5::md5_hex( rand(1024) );
1500 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1502 $arguments{'results'} = $key;
1505 $args{'Path'} =~ s!^/+!!;
1506 my $url = RT->Config->Get('WebURL') . $args{Path};
1508 if ( keys %arguments ) {
1509 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1511 if ( $args{'Anchor'} ) {
1512 $url .= "#". $args{'Anchor'};
1514 return RT::Interface::Web::Redirect($url);
1517 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1519 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1520 redirect to the approvals display page, preserving any arguments.
1522 C<Path>s matching C<Whitelist> are let through.
1524 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1528 sub MaybeRedirectToApproval {
1530 Path => $HTML::Mason::Commands::m->request_comp->path,
1536 return unless $ENV{REQUEST_METHOD} eq 'GET';
1538 my $id = $args{ARGSRef}->{id};
1541 and RT->Config->Get('ForceApprovalsView')
1542 and not $args{Path} =~ /$args{Whitelist}/)
1544 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1547 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1548 MaybeRedirectForResults(
1549 Path => "/Approvals/Display.html",
1551 Anchor => $args{ARGSRef}->{Anchor},
1552 Arguments => $args{ARGSRef},
1558 =head2 CreateTicket ARGS
1560 Create a new ticket, using Mason's %ARGS. returns @results.
1569 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1571 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1572 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1573 Abort('Queue not found');
1576 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1577 Abort('You have no permission to create tickets in that queue.');
1581 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1582 $due = RT::Date->new( $session{'CurrentUser'} );
1583 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1586 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1587 $starts = RT::Date->new( $session{'CurrentUser'} );
1588 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1591 my $sigless = RT::Interface::Web::StripContent(
1592 Content => $ARGS{Content},
1593 ContentType => $ARGS{ContentType},
1594 StripSignature => 1,
1595 CurrentUser => $session{'CurrentUser'},
1598 my $MIMEObj = MakeMIMEEntity(
1599 Subject => $ARGS{'Subject'},
1600 From => $ARGS{'From'},
1603 Type => $ARGS{'ContentType'},
1606 if ( $ARGS{'Attachments'} ) {
1607 my $rv = $MIMEObj->make_multipart;
1608 $RT::Logger->error("Couldn't make multipart message")
1609 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1611 foreach ( values %{ $ARGS{'Attachments'} } ) {
1613 $RT::Logger->error("Couldn't add empty attachemnt");
1616 $MIMEObj->add_part($_);
1620 foreach my $argument (qw(Encrypt Sign)) {
1621 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1622 if defined $ARGS{$argument};
1626 Type => $ARGS{'Type'} || 'ticket',
1627 Queue => $ARGS{'Queue'},
1628 Owner => $ARGS{'Owner'},
1631 Requestor => $ARGS{'Requestors'},
1633 AdminCc => $ARGS{'AdminCc'},
1634 InitialPriority => $ARGS{'InitialPriority'},
1635 FinalPriority => $ARGS{'FinalPriority'},
1636 TimeLeft => $ARGS{'TimeLeft'},
1637 TimeEstimated => $ARGS{'TimeEstimated'},
1638 TimeWorked => $ARGS{'TimeWorked'},
1639 Subject => $ARGS{'Subject'},
1640 Status => $ARGS{'Status'},
1641 Due => $due ? $due->ISO : undef,
1642 Starts => $starts ? $starts->ISO : undef,
1647 foreach my $type (qw(Requestor Cc AdminCc)) {
1648 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1649 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1651 $create_args{TransSquelchMailTo} = \@txn_squelch
1654 if ( $ARGS{'AttachTickets'} ) {
1655 require RT::Action::SendEmail;
1656 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1657 ref $ARGS{'AttachTickets'}
1658 ? @{ $ARGS{'AttachTickets'} }
1659 : ( $ARGS{'AttachTickets'} ) );
1662 foreach my $arg ( keys %ARGS ) {
1663 next if $arg =~ /-(?:Magic|Category)$/;
1665 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1666 $create_args{$arg} = $ARGS{$arg};
1669 # Object-RT::Ticket--CustomField-3-Values
1670 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1673 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1674 $cf->SetContextObject( $Queue );
1676 unless ( $cf->id ) {
1677 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1681 if ( $arg =~ /-Upload$/ ) {
1682 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1686 my $type = $cf->Type;
1689 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1690 @values = @{ $ARGS{$arg} };
1691 } elsif ( $type =~ /text/i ) {
1692 @values = ( $ARGS{$arg} );
1694 no warnings 'uninitialized';
1695 @values = split /\r*\n/, $ARGS{$arg};
1697 @values = grep length, map {
1703 grep defined, @values;
1705 $create_args{"CustomField-$cfid"} = \@values;
1709 # turn new link lists into arrays, and pass in the proper arguments
1711 'new-DependsOn' => 'DependsOn',
1712 'DependsOn-new' => 'DependedOnBy',
1713 'new-MemberOf' => 'Parents',
1714 'MemberOf-new' => 'Children',
1715 'new-RefersTo' => 'RefersTo',
1716 'RefersTo-new' => 'ReferredToBy',
1718 foreach my $key ( keys %map ) {
1719 next unless $ARGS{$key};
1720 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1724 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1729 push( @Actions, split( "\n", $ErrMsg ) );
1730 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1731 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1733 return ( $Ticket, @Actions );
1739 =head2 LoadTicket id
1741 Takes a ticket id as its only variable. if it's handed an array, it takes
1744 Returns an RT::Ticket object as the current user.
1751 if ( ref($id) eq "ARRAY" ) {
1756 Abort("No ticket specified");
1759 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1761 unless ( $Ticket->id ) {
1762 Abort("Could not load ticket $id");
1769 =head2 ProcessUpdateMessage
1771 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1773 Don't write message if it only contains current user's signature and
1774 SkipSignatureOnly argument is true. Function anyway adds attachments
1775 and updates time worked field even if skips message. The default value
1780 sub ProcessUpdateMessage {
1785 SkipSignatureOnly => 1,
1789 if ( $args{ARGSRef}->{'UpdateAttachments'}
1790 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1792 delete $args{ARGSRef}->{'UpdateAttachments'};
1795 # Strip the signature
1796 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1797 Content => $args{ARGSRef}->{UpdateContent},
1798 ContentType => $args{ARGSRef}->{UpdateContentType},
1799 StripSignature => $args{SkipSignatureOnly},
1800 CurrentUser => $args{'TicketObj'}->CurrentUser,
1803 # If, after stripping the signature, we have no message, move the
1804 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1805 # ProcessBasics can deal -- then bail out.
1806 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1807 and not length $args{ARGSRef}->{'UpdateContent'} )
1809 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1810 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1815 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1816 $args{ARGSRef}->{'UpdateSubject'} = undef;
1819 my $Message = MakeMIMEEntity(
1820 Subject => $args{ARGSRef}->{'UpdateSubject'},
1821 Body => $args{ARGSRef}->{'UpdateContent'},
1822 Type => $args{ARGSRef}->{'UpdateContentType'},
1825 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1826 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1828 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1829 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1830 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1832 $old_txn = $args{TicketObj}->Transactions->First();
1835 if ( my $msg = $old_txn->Message->First ) {
1836 RT::Interface::Email::SetInReplyTo(
1837 Message => $Message,
1842 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1843 $Message->make_multipart;
1844 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1847 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1848 require RT::Action::SendEmail;
1849 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1850 ref $args{ARGSRef}->{'AttachTickets'}
1851 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1852 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1855 my %txn_customfields;
1857 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1858 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1859 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1863 my %message_args = (
1864 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1865 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1866 MIMEObj => $Message,
1867 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1868 CustomFields => \%txn_customfields,
1871 _ProcessUpdateMessageRecipients(
1872 MessageArgs => \%message_args,
1877 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1878 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1879 push( @results, $Description );
1880 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1881 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1882 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1883 push( @results, $Description );
1884 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1887 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1892 sub _ProcessUpdateMessageRecipients {
1896 MessageArgs => undef,
1900 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1901 my $cc = $args{ARGSRef}->{'UpdateCc'};
1903 my $message_args = $args{MessageArgs};
1905 $message_args->{CcMessageTo} = $cc;
1906 $message_args->{BccMessageTo} = $bcc;
1909 foreach my $type (qw(Cc AdminCc)) {
1910 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1911 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1912 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1913 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1916 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1917 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1918 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1922 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1923 $message_args->{SquelchMailTo} = \@txn_squelch
1926 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1927 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1928 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1930 my $var = ucfirst($1) . 'MessageTo';
1932 if ( $message_args->{$var} ) {
1933 $message_args->{$var} .= ", $value";
1935 $message_args->{$var} = $value;
1941 =head2 MakeMIMEEntity PARAMHASH
1943 Takes a paramhash Subject, Body and AttachmentFieldName.
1945 Also takes Form, Cc and Type as optional paramhash keys.
1947 Returns a MIME::Entity.
1951 sub MakeMIMEEntity {
1953 #TODO document what else this takes.
1959 AttachmentFieldName => undef,
1963 my $Message = MIME::Entity->build(
1964 Type => 'multipart/mixed',
1965 "Message-Id" => RT::Interface::Email::GenMessageId,
1966 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1967 grep defined $args{$_}, qw(Subject From Cc)
1970 if ( defined $args{'Body'} && length $args{'Body'} ) {
1972 # Make the update content have no 'weird' newlines in it
1973 $args{'Body'} =~ s/\r\n/\n/gs;
1976 Type => $args{'Type'} || 'text/plain',
1978 Data => $args{'Body'},
1982 if ( $args{'AttachmentFieldName'} ) {
1984 my $cgi_object = $m->cgi_object;
1985 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1986 if ( defined $filehandle && length $filehandle ) {
1988 my ( @content, $buffer );
1989 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1990 push @content, $buffer;
1993 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1995 my $filename = "$filehandle";
1996 $filename =~ s{^.*[\\/]}{};
1999 Type => $uploadinfo->{'Content-Type'},
2000 Filename => $filename,
2003 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2004 $Message->head->set( 'Subject' => $filename );
2007 # Attachment parts really shouldn't get a Message-ID
2008 $Message->head->delete('Message-ID');
2012 $Message->make_singlepart;
2014 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2022 =head2 ParseDateToISO
2024 Takes a date in an arbitrary format.
2025 Returns an ISO date and time in GMT
2029 sub ParseDateToISO {
2032 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2034 Format => 'unknown',
2037 return ( $date_obj->ISO );
2042 sub ProcessACLChanges {
2043 my $ARGSref = shift;
2047 foreach my $arg ( keys %$ARGSref ) {
2048 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2050 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2053 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2054 @rights = @{ $ARGSref->{$arg} };
2056 @rights = $ARGSref->{$arg};
2058 @rights = grep $_, @rights;
2059 next unless @rights;
2061 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2062 $principal->Load($principal_id);
2065 if ( $object_type eq 'RT::System' ) {
2067 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2068 $obj = $object_type->new( $session{'CurrentUser'} );
2069 $obj->Load($object_id);
2070 unless ( $obj->id ) {
2071 $RT::Logger->error("couldn't load $object_type #$object_id");
2075 $RT::Logger->error("object type '$object_type' is incorrect");
2076 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2080 foreach my $right (@rights) {
2081 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2082 push( @results, $msg );
2092 ProcessACLs expects values from a series of checkboxes that describe the full
2093 set of rights a principal should have on an object.
2095 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2096 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2097 listing the rights the principal should have, and ProcessACLs will modify the
2098 current rights to match. Additionally, the previously unused CheckACL input
2099 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2100 rights are removed from a principal and as such no SetRights input is
2106 my $ARGSref = shift;
2107 my (%state, @results);
2109 my $CheckACL = $ARGSref->{'CheckACL'};
2110 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2112 # Check if we want to grant rights to a previously rights-less user
2113 for my $type (qw(user group)) {
2114 my $key = "AddPrincipalForRights-$type";
2116 next unless $ARGSref->{$key};
2119 if ( $type eq 'user' ) {
2120 $principal = RT::User->new( $session{'CurrentUser'} );
2121 $principal->LoadByCol( Name => $ARGSref->{$key} );
2124 $principal = RT::Group->new( $session{'CurrentUser'} );
2125 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2128 unless ($principal->PrincipalId) {
2129 push @results, loc("Couldn't load the specified principal");
2133 my $principal_id = $principal->PrincipalId;
2135 # Turn our addprincipal rights spec into a real one
2136 for my $arg (keys %$ARGSref) {
2137 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2139 my $tuple = "$principal_id-$1";
2140 my $key = "SetRights-$tuple";
2142 # If we have it already, that's odd, but merge them
2143 if (grep { $_ eq $tuple } @check) {
2144 $ARGSref->{$key} = [
2145 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2146 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2149 $ARGSref->{$key} = $ARGSref->{$arg};
2150 push @check, $tuple;
2155 # Build our rights state for each Principal-Object tuple
2156 foreach my $arg ( keys %$ARGSref ) {
2157 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2160 my $value = $ARGSref->{$arg};
2161 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2162 next unless @rights;
2164 $state{$tuple} = { map { $_ => 1 } @rights };
2167 foreach my $tuple (List::MoreUtils::uniq @check) {
2168 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2170 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2172 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2173 $principal->Load($principal_id);
2176 if ( $object_type eq 'RT::System' ) {
2178 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2179 $obj = $object_type->new( $session{'CurrentUser'} );
2180 $obj->Load($object_id);
2181 unless ( $obj->id ) {
2182 $RT::Logger->error("couldn't load $object_type #$object_id");
2186 $RT::Logger->error("object type '$object_type' is incorrect");
2187 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2191 my $acls = RT::ACL->new($session{'CurrentUser'});
2192 $acls->LimitToObject( $obj );
2193 $acls->LimitToPrincipal( Id => $principal_id );
2195 while ( my $ace = $acls->Next ) {
2196 my $right = $ace->RightName;
2198 # Has right and should have right
2199 next if delete $state{$tuple}->{$right};
2201 # Has right and shouldn't have right
2202 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2203 push @results, $msg;
2206 # For everything left, they don't have the right but they should
2207 for my $right (keys %{ $state{$tuple} || {} }) {
2208 delete $state{$tuple}->{$right};
2209 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2210 push @results, $msg;
2213 # Check our state for leftovers
2214 if ( keys %{ $state{$tuple} || {} } ) {
2215 my $missed = join '|', %{$state{$tuple} || {}};
2217 "Uh-oh, it looks like we somehow missed a right in "
2218 ."ProcessACLs. Here's what was leftover: $missed"
2229 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2231 @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.
2233 Returns an array of success/failure messages
2237 sub UpdateRecordObject {
2240 AttributesRef => undef,
2242 AttributePrefix => undef,
2246 my $Object = $args{'Object'};
2247 my @results = $Object->Update(
2248 AttributesRef => $args{'AttributesRef'},
2249 ARGSRef => $args{'ARGSRef'},
2250 AttributePrefix => $args{'AttributePrefix'},
2258 sub ProcessCustomFieldUpdates {
2260 CustomFieldObj => undef,
2265 my $Object = $args{'CustomFieldObj'};
2266 my $ARGSRef = $args{'ARGSRef'};
2268 my @attribs = qw(Name Type Description Queue SortOrder);
2269 my @results = UpdateRecordObject(
2270 AttributesRef => \@attribs,
2275 my $prefix = "CustomField-" . $Object->Id;
2276 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2277 my ( $addval, $addmsg ) = $Object->AddValue(
2278 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2279 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2280 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2282 push( @results, $addmsg );
2286 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2287 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2288 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2290 foreach my $id (@delete_values) {
2291 next unless defined $id;
2292 my ( $err, $msg ) = $Object->DeleteValue($id);
2293 push( @results, $msg );
2296 my $vals = $Object->Values();
2297 while ( my $cfv = $vals->Next() ) {
2298 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2299 if ( $cfv->SortOrder != $so ) {
2300 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2301 push( @results, $msg );
2311 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2313 Returns an array of results messages.
2317 sub ProcessTicketBasics {
2325 my $TicketObj = $args{'TicketObj'};
2326 my $ARGSRef = $args{'ARGSRef'};
2328 my $OrigOwner = $TicketObj->Owner;
2343 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2344 for my $field (qw(Queue Owner)) {
2345 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2346 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2347 my $temp = $class->new(RT->SystemUser);
2348 $temp->Load( $ARGSRef->{$field} );
2350 $ARGSRef->{$field} = $temp->id;
2355 # Status isn't a field that can be set to a null value.
2356 # RT core complains if you try
2357 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2359 my @results = UpdateRecordObject(
2360 AttributesRef => \@attribs,
2361 Object => $TicketObj,
2362 ARGSRef => $ARGSRef,
2365 # We special case owner changing, so we can use ForceOwnerChange
2366 if ( $ARGSRef->{'Owner'}
2367 && $ARGSRef->{'Owner'} !~ /\D/
2368 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2370 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2371 $ChownType = "Force";
2377 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2378 push( @results, $msg );
2386 sub ProcessTicketReminders {
2393 my $Ticket = $args{'TicketObj'};
2394 my $args = $args{'ARGSRef'};
2397 my $reminder_collection = $Ticket->Reminders->Collection;
2399 if ( $args->{'update-reminders'} ) {
2400 while ( my $reminder = $reminder_collection->Next ) {
2401 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2402 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2403 $Ticket->Reminders->Resolve($reminder);
2405 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2406 $Ticket->Reminders->Open($reminder);
2409 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2410 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2413 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2414 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2417 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2418 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2420 Format => 'unknown',
2421 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2423 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2424 $reminder->SetDue( $DateObj->ISO );
2430 if ( $args->{'NewReminder-Subject'} ) {
2431 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2433 Format => 'unknown',
2434 Value => $args->{'NewReminder-Due'}
2436 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2437 Subject => $args->{'NewReminder-Subject'},
2438 Owner => $args->{'NewReminder-Owner'},
2439 Due => $due_obj->ISO
2441 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2446 sub ProcessTicketCustomFieldUpdates {
2448 $args{'Object'} = delete $args{'TicketObj'};
2449 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2451 # Build up a list of objects that we want to work with
2452 my %custom_fields_to_mod;
2453 foreach my $arg ( keys %$ARGSRef ) {
2454 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2455 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2456 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2457 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2458 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2459 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2463 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2466 sub ProcessObjectCustomFieldUpdates {
2468 my $ARGSRef = $args{'ARGSRef'};
2471 # Build up a list of objects that we want to work with
2472 my %custom_fields_to_mod;
2473 foreach my $arg ( keys %$ARGSRef ) {
2475 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2476 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2478 # For each of those objects, find out what custom fields we want to work with.
2479 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2482 # For each of those objects
2483 foreach my $class ( keys %custom_fields_to_mod ) {
2484 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2485 my $Object = $args{'Object'};
2486 $Object = $class->new( $session{'CurrentUser'} )
2487 unless $Object && ref $Object eq $class;
2489 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2490 unless ( $Object->id ) {
2491 $RT::Logger->warning("Couldn't load object $class #$id");
2495 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2496 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2497 $CustomFieldObj->SetContextObject($Object);
2498 $CustomFieldObj->LoadById($cf);
2499 unless ( $CustomFieldObj->id ) {
2500 $RT::Logger->warning("Couldn't load custom field #$cf");
2504 _ProcessObjectCustomFieldUpdates(
2505 Prefix => "Object-$class-$id-CustomField-$cf-",
2507 CustomField => $CustomFieldObj,
2508 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2516 sub _ProcessObjectCustomFieldUpdates {
2518 my $cf = $args{'CustomField'};
2519 my $cf_type = $cf->Type || '';
2521 # Remove blank Values since the magic field will take care of this. Sometimes
2522 # the browser gives you a blank value which causes CFs to be processed twice
2523 if ( defined $args{'ARGS'}->{'Values'}
2524 && !length $args{'ARGS'}->{'Values'}
2525 && $args{'ARGS'}->{'Values-Magic'} )
2527 delete $args{'ARGS'}->{'Values'};
2531 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2533 # skip category argument
2534 next if $arg eq 'Category';
2537 next if $arg eq 'Value-TimeUnits';
2539 # since http won't pass in a form element with a null value, we need
2541 if ( $arg eq 'Values-Magic' ) {
2543 # We don't care about the magic, if there's really a values element;
2544 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2545 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2547 # "Empty" values does not mean anything for Image and Binary fields
2548 next if $cf_type =~ /^(?:Image|Binary)$/;
2551 $args{'ARGS'}->{'Values'} = undef;
2555 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2556 @values = @{ $args{'ARGS'}->{$arg} };
2557 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2558 @values = ( $args{'ARGS'}->{$arg} );
2560 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2561 if defined $args{'ARGS'}->{$arg};
2563 @values = grep length, map {
2569 grep defined, @values;
2571 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2572 foreach my $value (@values) {
2573 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2577 push( @results, $msg );
2579 } elsif ( $arg eq 'Upload' ) {
2580 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2581 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2582 push( @results, $msg );
2583 } elsif ( $arg eq 'DeleteValues' ) {
2584 foreach my $value (@values) {
2585 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2589 push( @results, $msg );
2591 } elsif ( $arg eq 'DeleteValueIds' ) {
2592 foreach my $value (@values) {
2593 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2597 push( @results, $msg );
2599 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2600 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2603 foreach my $value (@values) {
2604 if ( my $entry = $cf_values->HasEntry($value) ) {
2605 $values_hash{ $entry->id } = 1;
2609 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2613 push( @results, $msg );
2614 $values_hash{$val} = 1 if $val;
2617 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2618 return @results if ( $cf->Type eq 'Date' && ! @values );
2620 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2621 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2623 $cf_values->RedoSearch;
2624 while ( my $cf_value = $cf_values->Next ) {
2625 next if $values_hash{ $cf_value->id };
2627 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2629 ValueId => $cf_value->id
2631 push( @results, $msg );
2633 } elsif ( $arg eq 'Values' ) {
2634 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2636 # keep everything up to the point of difference, delete the rest
2638 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2639 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2648 # now add/replace extra things, if any
2649 foreach my $value (@values) {
2650 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2654 push( @results, $msg );
2659 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2660 $cf->Name, ref $args{'Object'},
2670 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2672 Returns an array of results messages.
2676 sub ProcessTicketWatchers {
2684 my $Ticket = $args{'TicketObj'};
2685 my $ARGSRef = $args{'ARGSRef'};
2689 foreach my $key ( keys %$ARGSRef ) {
2691 # Delete deletable watchers
2692 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2693 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2697 push @results, $msg;
2700 # Delete watchers in the simple style demanded by the bulk manipulator
2701 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2702 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2703 Email => $ARGSRef->{$key},
2706 push @results, $msg;
2709 # Add new wathchers by email address
2710 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2711 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2714 #They're in this order because otherwise $1 gets clobbered :/
2715 my ( $code, $msg ) = $Ticket->AddWatcher(
2716 Type => $ARGSRef->{$key},
2717 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2719 push @results, $msg;
2722 #Add requestors in the simple style demanded by the bulk manipulator
2723 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2724 my ( $code, $msg ) = $Ticket->AddWatcher(
2726 Email => $ARGSRef->{$key}
2728 push @results, $msg;
2731 # Add new watchers by owner
2732 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2733 my $principal_id = $1;
2734 my $form = $ARGSRef->{$key};
2735 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2736 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2738 my ( $code, $msg ) = $Ticket->AddWatcher(
2740 PrincipalId => $principal_id
2742 push @results, $msg;
2752 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2754 Returns an array of results messages.
2758 sub ProcessTicketDates {
2765 my $Ticket = $args{'TicketObj'};
2766 my $ARGSRef = $args{'ARGSRef'};
2771 my @date_fields = qw(
2779 #Run through each field in this list. update the value if apropriate
2780 foreach my $field (@date_fields) {
2781 next unless exists $ARGSRef->{ $field . '_Date' };
2782 next if $ARGSRef->{ $field . '_Date' } eq '';
2786 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2788 Format => 'unknown',
2789 Value => $ARGSRef->{ $field . '_Date' }
2792 my $obj = $field . "Obj";
2793 if ( ( defined $DateObj->Unix )
2794 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2796 my $method = "Set$field";
2797 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2798 push @results, "$msg";
2808 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2810 Returns an array of results messages.
2814 sub ProcessTicketLinks {
2821 my $Ticket = $args{'TicketObj'};
2822 my $ARGSRef = $args{'ARGSRef'};
2824 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2826 #Merge if we need to
2827 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2828 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2829 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2830 push @results, $msg;
2837 sub ProcessRecordLinks {
2844 my $Record = $args{'RecordObj'};
2845 my $ARGSRef = $args{'ARGSRef'};
2849 # Delete links that are gone gone gone.
2850 foreach my $arg ( keys %$ARGSRef ) {
2851 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2856 my ( $val, $msg ) = $Record->DeleteLink(
2862 push @results, $msg;
2868 my @linktypes = qw( DependsOn MemberOf RefersTo );
2870 foreach my $linktype (@linktypes) {
2871 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2872 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2873 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2875 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2877 $luri =~ s/\s+$//; # Strip trailing whitespace
2878 my ( $val, $msg ) = $Record->AddLink(
2882 push @results, $msg;
2885 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2886 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2887 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2889 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2891 my ( $val, $msg ) = $Record->AddLink(
2896 push @results, $msg;
2904 =head2 _UploadedFile ( $arg );
2906 Takes a CGI parameter name; if a file is uploaded under that name,
2907 return a hash reference suitable for AddCustomFieldValue's use:
2908 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2910 Returns C<undef> if no files were uploaded in the C<$arg> field.
2916 my $cgi_object = $m->cgi_object;
2917 my $fh = $cgi_object->upload($arg) or return undef;
2918 my $upload_info = $cgi_object->uploadInfo($fh);
2920 my $filename = "$fh";
2921 $filename =~ s#^.*[\\/]##;
2926 LargeContent => do { local $/; scalar <$fh> },
2927 ContentType => $upload_info->{'Content-Type'},
2931 sub GetColumnMapEntry {
2932 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2934 # deal with the simplest thing first
2935 if ( $args{'Map'}{ $args{'Name'} } ) {
2936 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2940 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2941 return undef unless $args{'Map'}->{$mainkey};
2942 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2943 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2945 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2950 sub ProcessColumnMapValue {
2952 my %args = ( Arguments => [], Escape => 1, @_ );
2955 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2956 my @tmp = $value->( @{ $args{'Arguments'} } );
2957 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2958 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2959 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2960 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2965 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2969 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2971 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2972 principal collections mapped from the categories given.
2976 sub GetPrincipalsMap {
2981 my $system = RT::Groups->new($session{'CurrentUser'});
2982 $system->LimitToSystemInternalGroups();
2983 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2985 'System' => $system, # loc_left_pair
2990 my $groups = RT::Groups->new($session{'CurrentUser'});
2991 $groups->LimitToUserDefinedGroups();
2992 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2994 # Only show groups who have rights granted on this object
2995 $groups->WithGroupRight(
2998 IncludeSystemRights => 0,
2999 IncludeSubgroupMembers => 0,
3003 'User Groups' => $groups, # loc_left_pair
3008 my $roles = RT::Groups->new($session{'CurrentUser'});
3010 if ($object->isa('RT::System')) {
3011 $roles->LimitToRolesForSystem();
3013 elsif ($object->isa('RT::Queue')) {
3014 $roles->LimitToRolesForQueue($object->Id);
3017 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3020 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3022 'Roles' => $roles, # loc_left_pair
3027 my $Users = RT->PrivilegedUsers->UserMembersObj();
3028 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3030 # Only show users who have rights granted on this object
3031 my $group_members = $Users->WhoHaveGroupRight(
3034 IncludeSystemRights => 0,
3035 IncludeSubgroupMembers => 0,
3038 # Limit to UserEquiv groups
3039 my $groups = $Users->NewAlias('Groups');
3043 ALIAS2 => $group_members,
3046 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3047 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3051 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3054 'Users' => $Users, # loc_left_pair
3062 =head2 _load_container_object ( $type, $id );
3064 Instantiate container object for saving searches.
3068 sub _load_container_object {
3069 my ( $obj_type, $obj_id ) = @_;
3070 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3073 =head2 _parse_saved_search ( $arg );
3075 Given a serialization string for saved search, and returns the
3076 container object and the search id.
3080 sub _parse_saved_search {
3082 return unless $spec;
3083 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3090 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3093 =head2 ScrubHTML content
3095 Removes unsafe and undesired HTML from the passed content
3101 my $Content = shift;
3102 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3104 $Content = '' if !defined($Content);
3105 return $SCRUBBER->scrub($Content);
3110 Returns a new L<HTML::Scrubber> object.
3112 If you need to be more lax about what HTML tags and attributes are allowed,
3113 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3116 package HTML::Mason::Commands;
3117 # Let tables through
3118 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3123 our @SCRUBBER_ALLOWED_TAGS = qw(
3124 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3125 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3128 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3129 # Match http, ftp and relative urls
3130 # XXX: we also scrub format strings with this module then allow simple config options
3131 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3137 (?:(?:background-)?color: \s*
3138 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3139 \#[a-f0-9]{3,6} | # #fff or #ffffff
3140 [\w\-]+ # green, light-blue, etc.
3142 text-align: \s* \w+ |
3143 font-size: \s* [\w.\-]+ |
3144 font-family: \s* [\w\s"',.\-]+ |
3145 font-weight: \s* [\w\-]+ |
3147 # MS Office styles, which are probably fine. If we don't, then any
3148 # associated styles in the same attribute get stripped.
3149 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3151 +$ # one or more of these allowed properties from here 'till sunset
3153 dir => qr/^(rtl|ltr)$/i,
3154 lang => qr/^\w+(-\w+)?$/,
3157 our %SCRUBBER_RULES = ();
3160 require HTML::Scrubber;
3161 my $scrubber = HTML::Scrubber->new();
3165 %SCRUBBER_ALLOWED_ATTRIBUTES,
3166 '*' => 0, # require attributes be explicitly allowed
3169 $scrubber->deny(qw[*]);
3170 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3171 $scrubber->rules(%SCRUBBER_RULES);
3173 # Scrubbing comments is vital since IE conditional comments can contain
3174 # arbitrary HTML and we'd pass it right on through.
3175 $scrubber->comment(0);
3182 Redispatches to L<RT::Interface::Web/EncodeJSON>
3187 RT::Interface::Web::EncodeJSON(@_);
3190 package RT::Interface::Web;
3191 RT::Base->_ImportOverlays();