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 );
265 if ( _UserLoggedIn() ) {
266 # make user info up to date
267 $HTML::Mason::Commands::session{'CurrentUser'}
268 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
271 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
274 # Process session-related callbacks before any auth attempts
275 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
277 MaybeRejectPrivateComponentRequest();
279 MaybeShowNoAuthPage($ARGS);
281 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
283 _ForceLogout() unless _UserLoggedIn();
285 # Process per-page authentication callbacks
286 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
288 unless ( _UserLoggedIn() ) {
291 # Authenticate if the user is trying to login via user/pass query args
292 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
295 my $m = $HTML::Mason::Commands::m;
297 # REST urls get a special 401 response
298 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
299 $HTML::Mason::Commands::r->content_type("text/plain");
300 $m->error_format("text");
301 $m->out("RT/$RT::VERSION 401 Credentials required\n");
302 $m->out("\n$msg\n") if $msg;
305 # Specially handle /index.html so that we get a nicer URL
306 elsif ( $m->request_comp->path eq '/index.html' ) {
307 my $next = SetNextPage(RT->Config->Get('WebURL'));
308 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
312 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
317 MaybeShowInterstitialCSRFPage($ARGS);
319 # now it applies not only to home page, but any dashboard that can be used as a workspace
320 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
321 if ( $ARGS->{'HomeRefreshInterval'} );
323 # Process per-page global callbacks
324 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
326 ShowRequestedPage($ARGS);
327 LogRecordedSQLStatements(RequestData => {
328 Path => $HTML::Mason::Commands::m->request_comp->path,
331 # Process per-page final cleanup callbacks
332 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
334 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
335 unless $HTML::Mason::Commands::r->content_type
336 =~ qr<^(text|application)/(x-)?(css|javascript)>;
341 delete $HTML::Mason::Commands::session{'CurrentUser'};
345 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
353 =head2 LoginError ERROR
355 Pushes a login error into the Actions session store and returns the hash key.
361 my $key = Digest::MD5::md5_hex( rand(1024) );
362 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
363 $HTML::Mason::Commands::session{'i'}++;
367 =head2 SetNextPage [PATH]
369 Intuits and stashes the next page in the sesssion hash. If PATH is
370 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
376 my $next = shift || IntuitNextPage();
377 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
379 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
380 $HTML::Mason::Commands::session{'i'}++;
385 =head2 TangentForLogin [HASH]
387 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
388 the next page. Optionally takes a hash which is dumped into query params.
392 sub TangentForLogin {
393 my $hash = SetNextPage();
394 my %query = (@_, next => $hash);
395 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
396 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
400 =head2 TangentForLoginWithError ERROR
402 Localizes the passed error message, stashes it with L<LoginError> and then
403 calls L<TangentForLogin> with the appropriate results key.
407 sub TangentForLoginWithError {
408 my $key = LoginError(HTML::Mason::Commands::loc(@_));
409 TangentForLogin( results => $key );
412 =head2 IntuitNextPage
414 Attempt to figure out the path to which we should return the user after a
415 tangent. The current request URL is used, or failing that, the C<WebURL>
416 configuration variable.
423 # This includes any query parameters. Redirect will take care of making
424 # it an absolute URL.
425 if ($ENV{'REQUEST_URI'}) {
426 $req_uri = $ENV{'REQUEST_URI'};
428 # collapse multiple leading slashes so the first part doesn't look like
429 # a hostname of a schema-less URI
430 $req_uri =~ s{^/+}{/};
433 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
436 my $uri = URI->new($next);
438 # You get undef scheme with a relative uri like "/Search/Build.html"
439 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
440 $next = RT->Config->Get('WebURL');
443 # Make sure we're logging in to the same domain
444 # You can get an undef authority with a relative uri like "index.html"
445 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
446 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
447 $next = RT->Config->Get('WebURL');
453 =head2 MaybeShowInstallModePage
455 This function, called exclusively by RT's autohandler, dispatches
456 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
458 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
462 sub MaybeShowInstallModePage {
463 return unless RT->InstallMode;
465 my $m = $HTML::Mason::Commands::m;
466 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
468 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
469 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
476 =head2 MaybeShowNoAuthPage \%ARGS
478 This function, called exclusively by RT's autohandler, dispatches
479 a request to the page a user requested (but only if it matches the "noauth" regex.
481 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
485 sub MaybeShowNoAuthPage {
488 my $m = $HTML::Mason::Commands::m;
490 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
492 # Don't show the login page to logged in users
493 Redirect(RT->Config->Get('WebURL'))
494 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
496 # If it's a noauth file, don't ask for auth.
497 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
501 =head2 MaybeRejectPrivateComponentRequest
503 This function will reject calls to private components, like those under
504 C</Elements>. If the requested path is a private component then we will
505 abort with a C<403> error.
509 sub MaybeRejectPrivateComponentRequest {
510 my $m = $HTML::Mason::Commands::m;
511 my $path = $m->request_comp->path;
513 # We do not check for dhandler here, because requesting our dhandlers
514 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
520 _elements | # mobile UI
522 autohandler | # requesting this directly is suspicious
523 l (_unsafe)? ) # loc component
524 ( $ | / ) # trailing slash or end of path
526 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
529 warn "rejecting private component $path\n";
537 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
538 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
539 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
544 =head2 ShowRequestedPage \%ARGS
546 This function, called exclusively by RT's autohandler, dispatches
547 a request to the page a user requested (making sure that unpriviled users
548 can only see self-service pages.
552 sub ShowRequestedPage {
555 my $m = $HTML::Mason::Commands::m;
557 # Ensure that the cookie that we send is up-to-date, in case the
558 # session-id has been modified in any way
561 # precache all system level rights for the current user
562 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
564 # If the user isn't privileged, they can only see SelfService
565 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
567 # if the user is trying to access a ticket, redirect them
568 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
569 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
572 # otherwise, drop the user at the SelfService default page
573 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
574 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
577 # if user is in SelfService dir let him do anything
579 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
582 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
587 sub AttemptExternalAuth {
590 return unless ( RT->Config->Get('WebExternalAuth') );
592 my $user = $ARGS->{user};
593 my $m = $HTML::Mason::Commands::m;
595 # If RT is configured for external auth, let's go through and get REMOTE_USER
597 # do we actually have a REMOTE_USER equivlent?
598 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
599 my $orig_user = $user;
601 $user = RT::Interface::Web::WebCanonicalizeInfo();
602 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
604 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
605 my $NodeName = Win32::NodeName();
606 $user =~ s/^\Q$NodeName\E\\//i;
609 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
610 InstantiateNewSession() unless _UserLoggedIn;
611 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
612 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
614 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
616 # Create users on-the-fly
617 my $UserObj = RT::User->new(RT->SystemUser);
618 my ( $val, $msg ) = $UserObj->Create(
619 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
626 # now get user specific information, to better create our user.
627 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
629 # set the attributes that have been defined.
630 foreach my $attribute ( $UserObj->WritableAttributes ) {
632 Attribute => $attribute,
634 UserInfo => $new_user_info,
635 CallbackName => 'NewUser',
636 CallbackPage => '/autohandler'
638 my $method = "Set$attribute";
639 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
641 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
644 # we failed to successfully create the user. abort abort abort.
645 delete $HTML::Mason::Commands::session{'CurrentUser'};
647 if (RT->Config->Get('WebFallbackToInternalAuth')) {
648 TangentForLoginWithError('Cannot create user: [_1]', $msg);
655 if ( _UserLoggedIn() ) {
656 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
657 # It is possible that we did a redirect to the login page,
658 # if the external auth allows lack of auth through with no
659 # REMOTE_USER set, instead of forcing a "permission
660 # denied" message. Honor the $next.
661 Redirect($next) if $next;
662 # Unlike AttemptPasswordAuthentication below, we do not
663 # force a redirect to / if $next is not set -- otherwise,
664 # straight-up external auth would always redirect to /
665 # when you first hit it.
667 delete $HTML::Mason::Commands::session{'CurrentUser'};
670 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
671 TangentForLoginWithError('You are not an authorized user');
674 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
675 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
676 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
677 TangentForLoginWithError('You are not an authorized user');
681 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
682 # XXX: we must return AUTH_REQUIRED status or we fallback to
683 # internal auth here too.
684 delete $HTML::Mason::Commands::session{'CurrentUser'}
685 if defined $HTML::Mason::Commands::session{'CurrentUser'};
689 sub AttemptPasswordAuthentication {
691 return unless defined $ARGS->{user} && defined $ARGS->{pass};
693 my $user_obj = RT::CurrentUser->new();
694 $user_obj->Load( $ARGS->{user} );
696 my $m = $HTML::Mason::Commands::m;
698 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
699 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
700 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
701 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
704 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
706 # It's important to nab the next page from the session before we blow
708 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
710 InstantiateNewSession();
711 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
713 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
715 # Really the only time we don't want to redirect here is if we were
716 # passed user and pass as query params in the URL.
720 elsif ($ARGS->{'next'}) {
721 # Invalid hash, but still wants to go somewhere, take them to /
722 Redirect(RT->Config->Get('WebURL'));
725 return (1, HTML::Mason::Commands::loc('Logged in'));
729 =head2 LoadSessionFromCookie
731 Load or setup a session cookie for the current user.
735 sub _SessionCookieName {
736 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
737 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
741 sub LoadSessionFromCookie {
743 my %cookies = CGI::Cookie->fetch;
744 my $cookiename = _SessionCookieName();
745 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
746 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
747 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
748 undef $cookies{$cookiename};
750 if ( int RT->Config->Get('AutoLogoff') ) {
751 my $now = int( time / 60 );
752 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
754 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
755 InstantiateNewSession();
758 # save session on each request when AutoLogoff is turned on
759 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
763 sub InstantiateNewSession {
764 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
765 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
769 sub SendSessionCookie {
770 my $cookie = CGI::Cookie->new(
771 -name => _SessionCookieName(),
772 -value => $HTML::Mason::Commands::session{_session_id},
773 -path => RT->Config->Get('WebPath'),
774 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
775 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
778 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
783 This routine ells the current user's browser to redirect to URL.
784 Additionally, it unties the user's currently active session, helping to avoid
785 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
786 a cached DBI statement handle twice at the same time.
791 my $redir_to = shift;
792 untie $HTML::Mason::Commands::session;
793 my $uri = URI->new($redir_to);
794 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
796 # Make relative URIs absolute from the server host and scheme
797 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
798 if (not defined $uri->host) {
799 $uri->host($server_uri->host);
800 $uri->port($server_uri->port);
803 # If the user is coming in via a non-canonical
804 # hostname, don't redirect them to the canonical host,
805 # it will just upset them (and invalidate their credentials)
806 # don't do this if $RT::CanonicalizeRedirectURLs is true
807 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
808 && $uri->host eq $server_uri->host
809 && $uri->port eq $server_uri->port )
811 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
812 $uri->scheme('https');
814 $uri->scheme('http');
817 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
818 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
819 $uri->port( $ENV{'SERVER_PORT'} );
822 # not sure why, but on some systems without this call mason doesn't
823 # set status to 302, but 200 instead and people see blank pages
824 $HTML::Mason::Commands::r->status(302);
826 # Perlbal expects a status message, but Mason's default redirect status
827 # doesn't provide one. See also rt.cpan.org #36689.
828 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
830 $HTML::Mason::Commands::m->abort;
833 =head2 StaticFileHeaders
835 Send the browser a few headers to try to get it to (somewhat agressively)
836 cache RT's static Javascript and CSS files.
838 This routine could really use _accurate_ heuristics. (XXX TODO)
842 sub StaticFileHeaders {
843 my $date = RT::Date->new(RT->SystemUser);
846 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
848 # remove any cookie headers -- if it is cached publicly, it
849 # shouldn't include anyone's cookie!
850 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
852 # Expire things in a month.
853 $date->Set( Value => time + 30 * 24 * 60 * 60 );
854 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
856 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
857 # request, but we don't handle it and generate full reply again
858 # Last modified at server start time
859 # $date->Set( Value => $^T );
860 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
863 =head2 ComponentPathIsSafe PATH
865 Takes C<PATH> and returns a boolean indicating that the user-specified partial
866 component path is safe.
868 Currently "safe" means that the path does not start with a dot (C<.>) and does
869 not contain a slash-dot C</.>.
873 sub ComponentPathIsSafe {
876 return $path !~ m{(?:^|/)\.};
881 Takes a C<< Path => path >> and returns a boolean indicating that
882 the path is safely within RT's control or not. The path I<must> be
885 This function does not consult the filesystem at all; it is merely
886 a logical sanity checking of the path. This explicitly does not handle
887 symlinks; if you have symlinks in RT's webroot pointing outside of it,
888 then we assume you know what you are doing.
895 my $path = $args{Path};
897 # Get File::Spec to clean up extra /s, ./, etc
898 my $cleaned_up = File::Spec->canonpath($path);
900 if (!defined($cleaned_up)) {
901 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
905 # Forbid too many ..s. We can't just sum then check because
906 # "../foo/bar/baz" should be illegal even though it has more
907 # downdirs than updirs. So as soon as we get a negative score
908 # (which means "breaking out" of the top level) we reject the path.
910 my @components = split '/', $cleaned_up;
912 for my $component (@components) {
913 if ($component eq '..') {
916 $RT::Logger->info("Rejecting unsafe path: $path");
920 elsif ($component eq '.' || $component eq '') {
921 # these two have no effect on $score
931 =head2 SendStaticFile
933 Takes a File => path and a Type => Content-type
935 If Type isn't provided and File is an image, it will
936 figure out a sane Content-type, otherwise it will
937 send application/octet-stream
939 Will set caching headers using StaticFileHeaders
946 my $file = $args{File};
947 my $type = $args{Type};
948 my $relfile = $args{RelativeFile};
950 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
951 $HTML::Mason::Commands::r->status(400);
952 $HTML::Mason::Commands::m->abort;
955 $self->StaticFileHeaders();
958 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
960 $type =~ s/jpg/jpeg/gi;
962 $type ||= "application/octet-stream";
964 $HTML::Mason::Commands::r->content_type($type);
965 open( my $fh, '<', $file ) or die "couldn't open file: $!";
969 $HTML::Mason::Commands::m->out($_) while (<$fh>);
970 $HTML::Mason::Commands::m->flush_buffer;
981 if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
992 my $content = $args{Content};
993 return '' unless $content;
995 # Make the content have no 'weird' newlines in it
996 $content =~ s/\r+\n/\n/g;
998 my $return_content = $content;
1000 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1001 my $sigonly = $args{StripSignature};
1003 # massage content to easily detect if there's any real content
1004 $content =~ s/\s+//g; # yes! remove all the spaces
1006 # remove html version of spaces and newlines
1007 $content =~ s! !!g;
1008 $content =~ s!<br/?>!!g;
1011 # Filter empty content when type is text/html
1012 return '' if $html && $content !~ /\S/;
1014 # If we aren't supposed to strip the sig, just bail now.
1015 return $return_content unless $sigonly;
1017 # Find the signature
1018 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1021 # Check for plaintext sig
1022 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1024 # Check for html-formatted sig; we don't use EscapeUTF8 here
1025 # because we want to precisely match the escapting that FCKEditor
1027 $sig =~ s/&/&/g;
1030 $sig =~ s/"/"/g;
1031 $sig =~ s/'/'/g;
1032 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1035 return $return_content;
1043 # if they've passed multiple values, they'll be an array. if they've
1044 # passed just one, a scalar whatever they are, mark them as utf8
1047 ? Encode::is_utf8($_)
1049 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1050 : ( $type eq 'ARRAY' )
1051 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1053 : ( $type eq 'HASH' )
1054 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1060 sub PreprocessTimeUpdates {
1063 # Later in the code we use
1064 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1065 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1066 # The call_next method pass through original arguments and if you have
1067 # an argument with unicode key then in a next component you'll get two
1068 # records in the args hash: one with key without UTF8 flag and another
1069 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1070 # is copied from mason's source to get the same results as we get from
1071 # call_next method, this feature is not documented, so we just leave it
1072 # here to avoid possible side effects.
1074 # This code canonicalizes time inputs in hours into minutes
1075 foreach my $field ( keys %$ARGS ) {
1076 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1078 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1079 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1080 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1081 $ARGS->{$local} *= 60;
1083 delete $ARGS->{$field};
1088 sub MaybeEnableSQLStatementLog {
1090 my $log_sql_statements = RT->Config->Get('StatementLog');
1092 if ($log_sql_statements) {
1093 $RT::Handle->ClearSQLStatementLog;
1094 $RT::Handle->LogSQLStatements(1);
1099 sub LogRecordedSQLStatements {
1102 my $log_sql_statements = RT->Config->Get('StatementLog');
1104 return unless ($log_sql_statements);
1106 my @log = $RT::Handle->SQLStatementLog;
1107 $RT::Handle->ClearSQLStatementLog;
1109 $RT::Handle->AddRequestToHistory({
1110 %{ $args{RequestData} },
1114 for my $stmt (@log) {
1115 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1125 level => $log_sql_statements,
1127 . sprintf( "%.6f", $duration )
1129 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1135 my $_has_validated_web_config = 0;
1136 sub ValidateWebConfig {
1139 # do this once per server instance, not once per request
1140 return if $_has_validated_web_config;
1141 $_has_validated_web_config = 1;
1143 if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) {
1144 $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.");
1147 if ($ENV{HTTP_HOST}) {
1148 # match "example.com" or "example.com:80"
1149 my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/;
1151 if ($host ne RT->Config->Get('WebDomain')) {
1152 $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.");
1156 if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) {
1157 $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.");
1161 #i don't understand how this was ever expected to work
1162 # (even without our dum double // hack)??
1163 #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1164 ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g;
1165 ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g;
1166 my $script_name_prefix = substr($script_name, 0, length($WebPath));
1167 if ( $script_name_prefix ne $WebPath ) {
1168 $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.");
1172 sub ComponentRoots {
1174 my %args = ( Names => 0, @_ );
1176 if (defined $HTML::Mason::Commands::m) {
1177 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1180 [ local => $RT::MasonLocalComponentRoot ],
1181 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1182 [ standard => $RT::MasonComponentRoot ]
1185 @roots = map { $_->[1] } @roots unless $args{Names};
1189 our %is_whitelisted_component = (
1190 # The RSS feed embeds an auth token in the path, but query
1191 # information for the search. Because it's a straight-up read, in
1192 # addition to embedding its own auth, it's fine.
1193 '/NoAuth/rss/dhandler' => 1,
1195 # While these can be used for denial-of-service against RT
1196 # (construct a very inefficient query and trick lots of users into
1197 # running them against RT) it's incredibly useful to be able to link
1198 # to a search result or bookmark a result page.
1199 '/Search/Results.html' => 1,
1200 '/Search/Simple.html' => 1,
1201 '/m/tickets/search' => 1,
1204 sub IsCompCSRFWhitelisted {
1208 return 1 if $is_whitelisted_component{$comp};
1210 my %args = %{ $ARGS };
1212 # If the user specifies a *correct* user and pass then they are
1213 # golden. This acts on the presumption that external forms may
1214 # hardcode a username and password -- if a malicious attacker knew
1215 # both already, CSRF is the least of your problems.
1216 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1217 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1218 my $user_obj = RT::CurrentUser->new();
1219 $user_obj->Load($args{user});
1220 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1226 # Eliminate arguments that do not indicate an effectful request.
1227 # For example, "id" is acceptable because that is how RT retrieves a
1231 # If they have a valid results= from MaybeRedirectForResults, that's
1233 delete $args{results} if $args{results}
1234 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1236 # The homepage refresh, which uses the Refresh header, doesn't send
1237 # a referer in most browsers; whitelist the one parameter it reloads
1238 # with, HomeRefreshInterval, which is safe
1239 delete $args{HomeRefreshInterval};
1241 # If there are no arguments, then it's likely to be an idempotent
1242 # request, which are not susceptible to CSRF
1248 sub IsRefererCSRFWhitelisted {
1249 my $referer = _NormalizeHost(shift);
1250 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1251 $base_url = $base_url->host_port;
1254 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1255 push @$configs,$config;
1257 my $host_port = $referer->host_port;
1258 if ($config =~ /\*/) {
1259 # Turn a literal * into a domain component or partial component match.
1260 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1261 my $regex = join "[a-zA-Z0-9\-]*",
1262 map { quotemeta($_) }
1263 split /\*/, $config;
1265 return 1 if $host_port =~ /^$regex$/i;
1267 return 1 if $host_port eq $config;
1271 return (0,$referer,$configs);
1274 =head3 _NormalizeHost
1276 Takes a URI and creates a URI object that's been normalized
1277 to handle common problems such as localhost vs 127.0.0.1
1281 sub _NormalizeHost {
1283 $s = "http://$s" unless $s =~ /^http/i;
1284 my $uri= URI->new($s);
1285 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1291 sub IsPossibleCSRF {
1294 # If first request on this session is to a REST endpoint, then
1295 # whitelist the REST endpoints -- and explicitly deny non-REST
1296 # endpoints. We do this because using a REST cookie in a browser
1297 # would open the user to CSRF attacks to the REST endpoints.
1298 my $path = $HTML::Mason::Commands::r->path_info;
1299 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1300 unless defined $HTML::Mason::Commands::session{'REST'};
1302 if ($HTML::Mason::Commands::session{'REST'}) {
1303 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1305 This login session belongs to a REST client, and cannot be used to
1306 access non-REST interfaces of RT for security reasons.
1308 my $details = <<EOT;
1309 Please log out and back in to obtain a session for normal browsing. If
1310 you understand the security implications, disabling RT's CSRF protection
1311 will remove this restriction.
1314 HTML::Mason::Commands::Abort( $why, Details => $details );
1317 return 0 if IsCompCSRFWhitelisted(
1318 $HTML::Mason::Commands::m->request_comp->path,
1322 # if there is no Referer header then assume the worst
1324 "your browser did not supply a Referrer header", # loc
1325 ) if !$ENV{HTTP_REFERER};
1327 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1328 return 0 if $whitelisted;
1330 if ( @$configs > 1 ) {
1332 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1333 $browser->host_port,
1335 join(', ', @$configs) );
1339 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1340 $browser->host_port,
1344 sub ExpandCSRFToken {
1347 my $token = delete $ARGS->{CSRF_Token};
1348 return unless $token;
1350 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1351 return unless $data;
1352 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1354 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1355 return unless $user->ValidateAuthString( $data->{auth}, $token );
1357 %{$ARGS} = %{$data->{args}};
1358 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1360 # We explicitly stored file attachments with the request, but not in
1361 # the session yet, as that would itself be an attack. Put them into
1362 # the session now, so they'll be visible.
1363 if ($data->{attach}) {
1364 my $filename = $data->{attach}{filename};
1365 my $mime = $data->{attach}{mime};
1366 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1373 sub StoreRequestToken {
1376 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1377 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1379 auth => $user->GenerateAuthString( $token ),
1380 path => $HTML::Mason::Commands::r->path_info,
1383 if ($ARGS->{Attach}) {
1384 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1385 my $file_path = delete $ARGS->{'Attach'};
1387 filename => Encode::decode_utf8("$file_path"),
1388 mime => $attachment,
1392 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1393 $HTML::Mason::Commands::session{'i'}++;
1397 sub MaybeShowInterstitialCSRFPage {
1400 return unless RT->Config->Get('RestrictReferrer');
1402 # Deal with the form token provided by the interstitial, which lets
1403 # browsers which never set referer headers still use RT, if
1404 # painfully. This blows values into ARGS
1405 return if ExpandCSRFToken($ARGS);
1407 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1408 return if !$is_csrf;
1410 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1412 my $token = StoreRequestToken($ARGS);
1413 $HTML::Mason::Commands::m->comp(
1415 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1416 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1419 # Calls abort, never gets here
1422 package HTML::Mason::Commands;
1424 use vars qw/$r $m %session/;
1427 return $HTML::Mason::Commands::m->notes('menu');
1431 return $HTML::Mason::Commands::m->notes('page-menu');
1435 return $HTML::Mason::Commands::m->notes('page-widgets');
1442 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1443 with whatever it's called with. If there is no $session{'CurrentUser'},
1444 it creates a temporary user, so we have something to get a localisation handle
1451 if ( $session{'CurrentUser'}
1452 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1454 return ( $session{'CurrentUser'}->loc(@_) );
1457 RT::CurrentUser->new();
1461 return ( $u->loc(@_) );
1464 # pathetic case -- SystemUser is gone.
1471 =head2 loc_fuzzy STRING
1473 loc_fuzzy is for handling localizations of messages that may already
1474 contain interpolated variables, typically returned from libraries
1475 outside RT's control. It takes the message string and extracts the
1476 variable array automatically by matching against the candidate entries
1477 inside the lexicon file.
1484 if ( $session{'CurrentUser'}
1485 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1487 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1489 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1490 return ( $u->loc_fuzzy($msg) );
1495 # Error - calls Error and aborts
1500 if ( $session{'ErrorDocument'}
1501 && $session{'ErrorDocumentType'} )
1503 $r->content_type( $session{'ErrorDocumentType'} );
1504 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1507 $m->comp( "/Elements/Error", Why => $why, %args );
1512 sub MaybeRedirectForResults {
1514 Path => $HTML::Mason::Commands::m->request_comp->path,
1521 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1522 return unless $has_actions || $args{'Force'};
1524 my %arguments = %{ $args{'Arguments'} };
1526 if ( $has_actions ) {
1527 my $key = Digest::MD5::md5_hex( rand(1024) );
1528 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1530 $arguments{'results'} = $key;
1533 $args{'Path'} =~ s!^/+!!;
1534 my $url = RT->Config->Get('WebURL') . $args{Path};
1536 if ( keys %arguments ) {
1537 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1539 if ( $args{'Anchor'} ) {
1540 $url .= "#". $args{'Anchor'};
1542 return RT::Interface::Web::Redirect($url);
1545 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1547 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1548 redirect to the approvals display page, preserving any arguments.
1550 C<Path>s matching C<Whitelist> are let through.
1552 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1556 sub MaybeRedirectToApproval {
1558 Path => $HTML::Mason::Commands::m->request_comp->path,
1564 return unless $ENV{REQUEST_METHOD} eq 'GET';
1566 my $id = $args{ARGSRef}->{id};
1569 and RT->Config->Get('ForceApprovalsView')
1570 and not $args{Path} =~ /$args{Whitelist}/)
1572 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1575 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1576 MaybeRedirectForResults(
1577 Path => "/Approvals/Display.html",
1579 Anchor => $args{ARGSRef}->{Anchor},
1580 Arguments => $args{ARGSRef},
1586 =head2 CreateTicket ARGS
1588 Create a new ticket, using Mason's %ARGS. returns @results.
1597 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1599 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1600 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1601 Abort('Queue not found');
1604 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1605 Abort('You have no permission to create tickets in that queue.');
1609 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1610 $due = RT::Date->new( $session{'CurrentUser'} );
1611 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1614 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1615 $starts = RT::Date->new( $session{'CurrentUser'} );
1616 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1619 my $sigless = RT::Interface::Web::StripContent(
1620 Content => $ARGS{Content},
1621 ContentType => $ARGS{ContentType},
1622 StripSignature => 1,
1623 CurrentUser => $session{'CurrentUser'},
1626 my $MIMEObj = MakeMIMEEntity(
1627 Subject => $ARGS{'Subject'},
1628 From => $ARGS{'From'},
1631 Type => $ARGS{'ContentType'},
1634 if ( $ARGS{'Attachments'} ) {
1635 my $rv = $MIMEObj->make_multipart;
1636 $RT::Logger->error("Couldn't make multipart message")
1637 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1639 foreach ( values %{ $ARGS{'Attachments'} } ) {
1641 $RT::Logger->error("Couldn't add empty attachemnt");
1644 $MIMEObj->add_part($_);
1648 foreach my $argument (qw(Encrypt Sign)) {
1649 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1650 if defined $ARGS{$argument};
1654 Type => $ARGS{'Type'} || 'ticket',
1655 Queue => $ARGS{'Queue'},
1656 Owner => $ARGS{'Owner'},
1659 Requestor => $ARGS{'Requestors'},
1661 AdminCc => $ARGS{'AdminCc'},
1662 InitialPriority => $ARGS{'InitialPriority'},
1663 FinalPriority => $ARGS{'FinalPriority'},
1664 TimeLeft => $ARGS{'TimeLeft'},
1665 TimeEstimated => $ARGS{'TimeEstimated'},
1666 TimeWorked => $ARGS{'TimeWorked'},
1667 Subject => $ARGS{'Subject'},
1668 Status => $ARGS{'Status'},
1669 Due => $due ? $due->ISO : undef,
1670 Starts => $starts ? $starts->ISO : undef,
1675 foreach my $type (qw(Requestor Cc AdminCc)) {
1676 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1677 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1679 $create_args{TransSquelchMailTo} = \@txn_squelch
1682 if ( $ARGS{'AttachTickets'} ) {
1683 require RT::Action::SendEmail;
1684 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1685 ref $ARGS{'AttachTickets'}
1686 ? @{ $ARGS{'AttachTickets'} }
1687 : ( $ARGS{'AttachTickets'} ) );
1690 foreach my $arg ( keys %ARGS ) {
1691 next if $arg =~ /-(?:Magic|Category)$/;
1693 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1694 $create_args{$arg} = $ARGS{$arg};
1697 # Object-RT::Ticket--CustomField-3-Values
1698 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1701 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1702 $cf->SetContextObject( $Queue );
1704 unless ( $cf->id ) {
1705 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1709 if ( $arg =~ /-Upload$/ ) {
1710 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1714 my $type = $cf->Type;
1717 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1718 @values = @{ $ARGS{$arg} };
1719 } elsif ( $type =~ /text/i ) {
1720 @values = ( $ARGS{$arg} );
1722 no warnings 'uninitialized';
1723 @values = split /\r*\n/, $ARGS{$arg};
1725 @values = grep length, map {
1731 grep defined, @values;
1733 $create_args{"CustomField-$cfid"} = \@values;
1737 # turn new link lists into arrays, and pass in the proper arguments
1739 'new-DependsOn' => 'DependsOn',
1740 'DependsOn-new' => 'DependedOnBy',
1741 'new-MemberOf' => 'Parents',
1742 'MemberOf-new' => 'Children',
1743 'new-RefersTo' => 'RefersTo',
1744 'RefersTo-new' => 'ReferredToBy',
1746 foreach my $key ( keys %map ) {
1747 next unless $ARGS{$key};
1748 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1752 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1757 push( @Actions, split( "\n", $ErrMsg ) );
1758 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1759 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1761 return ( $Ticket, @Actions );
1767 =head2 LoadTicket id
1769 Takes a ticket id as its only variable. if it's handed an array, it takes
1772 Returns an RT::Ticket object as the current user.
1779 if ( ref($id) eq "ARRAY" ) {
1784 Abort("No ticket specified");
1787 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1789 unless ( $Ticket->id ) {
1790 Abort("Could not load ticket $id");
1797 =head2 ProcessUpdateMessage
1799 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1801 Don't write message if it only contains current user's signature and
1802 SkipSignatureOnly argument is true. Function anyway adds attachments
1803 and updates time worked field even if skips message. The default value
1808 sub ProcessUpdateMessage {
1813 SkipSignatureOnly => 1,
1817 if ( $args{ARGSRef}->{'UpdateAttachments'}
1818 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1820 delete $args{ARGSRef}->{'UpdateAttachments'};
1823 # Strip the signature
1824 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1825 Content => $args{ARGSRef}->{UpdateContent},
1826 ContentType => $args{ARGSRef}->{UpdateContentType},
1827 StripSignature => $args{SkipSignatureOnly},
1828 CurrentUser => $args{'TicketObj'}->CurrentUser,
1831 # If, after stripping the signature, we have no message, move the
1832 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1833 # ProcessBasics can deal -- then bail out.
1834 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1835 and not length $args{ARGSRef}->{'UpdateContent'} )
1837 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1838 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1843 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1844 $args{ARGSRef}->{'UpdateSubject'} = undef;
1847 my $Message = MakeMIMEEntity(
1848 Subject => $args{ARGSRef}->{'UpdateSubject'},
1849 Body => $args{ARGSRef}->{'UpdateContent'},
1850 Type => $args{ARGSRef}->{'UpdateContentType'},
1853 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1854 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1856 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1857 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1858 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1860 $old_txn = $args{TicketObj}->Transactions->First();
1863 if ( my $msg = $old_txn->Message->First ) {
1864 RT::Interface::Email::SetInReplyTo(
1865 Message => $Message,
1870 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1871 $Message->make_multipart;
1872 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1875 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1876 require RT::Action::SendEmail;
1877 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1878 ref $args{ARGSRef}->{'AttachTickets'}
1879 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1880 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1883 my %txn_customfields;
1885 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1886 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1887 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1891 my %message_args = (
1892 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1893 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1894 MIMEObj => $Message,
1895 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1896 CustomFields => \%txn_customfields,
1899 _ProcessUpdateMessageRecipients(
1900 MessageArgs => \%message_args,
1905 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1906 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1907 push( @results, $Description );
1908 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1909 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1910 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1911 push( @results, $Description );
1912 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1915 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1920 sub _ProcessUpdateMessageRecipients {
1924 MessageArgs => undef,
1928 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1929 my $cc = $args{ARGSRef}->{'UpdateCc'};
1931 my $message_args = $args{MessageArgs};
1933 $message_args->{CcMessageTo} = $cc;
1934 $message_args->{BccMessageTo} = $bcc;
1937 foreach my $type (qw(Cc AdminCc)) {
1938 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1939 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1940 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1941 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1944 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1945 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1946 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1950 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1951 $message_args->{SquelchMailTo} = \@txn_squelch
1954 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1955 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1956 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1958 my $var = ucfirst($1) . 'MessageTo';
1960 if ( $message_args->{$var} ) {
1961 $message_args->{$var} .= ", $value";
1963 $message_args->{$var} = $value;
1969 =head2 MakeMIMEEntity PARAMHASH
1971 Takes a paramhash Subject, Body and AttachmentFieldName.
1973 Also takes Form, Cc and Type as optional paramhash keys.
1975 Returns a MIME::Entity.
1979 sub MakeMIMEEntity {
1981 #TODO document what else this takes.
1987 AttachmentFieldName => undef,
1991 my $Message = MIME::Entity->build(
1992 Type => 'multipart/mixed',
1993 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
1994 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1995 grep defined $args{$_}, qw(Subject From Cc)
1998 if ( defined $args{'Body'} && length $args{'Body'} ) {
2000 # Make the update content have no 'weird' newlines in it
2001 $args{'Body'} =~ s/\r\n/\n/gs;
2004 Type => $args{'Type'} || 'text/plain',
2006 Data => $args{'Body'},
2010 if ( $args{'AttachmentFieldName'} ) {
2012 my $cgi_object = $m->cgi_object;
2013 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2014 if ( defined $filehandle && length $filehandle ) {
2016 my ( @content, $buffer );
2017 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2018 push @content, $buffer;
2021 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2023 my $filename = "$filehandle";
2024 $filename =~ s{^.*[\\/]}{};
2027 Type => $uploadinfo->{'Content-Type'},
2028 Filename => $filename,
2031 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2032 $Message->head->set( 'Subject' => $filename );
2035 # Attachment parts really shouldn't get a Message-ID
2036 $Message->head->delete('Message-ID');
2040 $Message->make_singlepart;
2042 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2050 =head2 ParseDateToISO
2052 Takes a date in an arbitrary format.
2053 Returns an ISO date and time in GMT
2057 sub ParseDateToISO {
2060 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2062 Format => 'unknown',
2065 return ( $date_obj->ISO );
2070 sub ProcessACLChanges {
2071 my $ARGSref = shift;
2075 foreach my $arg ( keys %$ARGSref ) {
2076 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2078 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2081 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2082 @rights = @{ $ARGSref->{$arg} };
2084 @rights = $ARGSref->{$arg};
2086 @rights = grep $_, @rights;
2087 next unless @rights;
2089 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2090 $principal->Load($principal_id);
2093 if ( $object_type eq 'RT::System' ) {
2095 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2096 $obj = $object_type->new( $session{'CurrentUser'} );
2097 $obj->Load($object_id);
2098 unless ( $obj->id ) {
2099 $RT::Logger->error("couldn't load $object_type #$object_id");
2103 $RT::Logger->error("object type '$object_type' is incorrect");
2104 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2108 foreach my $right (@rights) {
2109 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2110 push( @results, $msg );
2120 ProcessACLs expects values from a series of checkboxes that describe the full
2121 set of rights a principal should have on an object.
2123 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2124 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2125 listing the rights the principal should have, and ProcessACLs will modify the
2126 current rights to match. Additionally, the previously unused CheckACL input
2127 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2128 rights are removed from a principal and as such no SetRights input is
2134 my $ARGSref = shift;
2135 my (%state, @results);
2137 my $CheckACL = $ARGSref->{'CheckACL'};
2138 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2140 # Check if we want to grant rights to a previously rights-less user
2141 for my $type (qw(user group)) {
2142 my $key = "AddPrincipalForRights-$type";
2144 next unless $ARGSref->{$key};
2147 if ( $type eq 'user' ) {
2148 $principal = RT::User->new( $session{'CurrentUser'} );
2149 $principal->LoadByCol( Name => $ARGSref->{$key} );
2152 $principal = RT::Group->new( $session{'CurrentUser'} );
2153 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2156 unless ($principal->PrincipalId) {
2157 push @results, loc("Couldn't load the specified principal");
2161 my $principal_id = $principal->PrincipalId;
2163 # Turn our addprincipal rights spec into a real one
2164 for my $arg (keys %$ARGSref) {
2165 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2167 my $tuple = "$principal_id-$1";
2168 my $key = "SetRights-$tuple";
2170 # If we have it already, that's odd, but merge them
2171 if (grep { $_ eq $tuple } @check) {
2172 $ARGSref->{$key} = [
2173 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2174 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2177 $ARGSref->{$key} = $ARGSref->{$arg};
2178 push @check, $tuple;
2183 # Build our rights state for each Principal-Object tuple
2184 foreach my $arg ( keys %$ARGSref ) {
2185 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2188 my $value = $ARGSref->{$arg};
2189 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2190 next unless @rights;
2192 $state{$tuple} = { map { $_ => 1 } @rights };
2195 foreach my $tuple (List::MoreUtils::uniq @check) {
2196 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2198 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2200 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2201 $principal->Load($principal_id);
2204 if ( $object_type eq 'RT::System' ) {
2206 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2207 $obj = $object_type->new( $session{'CurrentUser'} );
2208 $obj->Load($object_id);
2209 unless ( $obj->id ) {
2210 $RT::Logger->error("couldn't load $object_type #$object_id");
2214 $RT::Logger->error("object type '$object_type' is incorrect");
2215 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2219 my $acls = RT::ACL->new($session{'CurrentUser'});
2220 $acls->LimitToObject( $obj );
2221 $acls->LimitToPrincipal( Id => $principal_id );
2223 while ( my $ace = $acls->Next ) {
2224 my $right = $ace->RightName;
2226 # Has right and should have right
2227 next if delete $state{$tuple}->{$right};
2229 # Has right and shouldn't have right
2230 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2231 push @results, $msg;
2234 # For everything left, they don't have the right but they should
2235 for my $right (keys %{ $state{$tuple} || {} }) {
2236 delete $state{$tuple}->{$right};
2237 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2238 push @results, $msg;
2241 # Check our state for leftovers
2242 if ( keys %{ $state{$tuple} || {} } ) {
2243 my $missed = join '|', %{$state{$tuple} || {}};
2245 "Uh-oh, it looks like we somehow missed a right in "
2246 ."ProcessACLs. Here's what was leftover: $missed"
2257 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2259 @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.
2261 Returns an array of success/failure messages
2265 sub UpdateRecordObject {
2268 AttributesRef => undef,
2270 AttributePrefix => undef,
2274 my $Object = $args{'Object'};
2275 my @results = $Object->Update(
2276 AttributesRef => $args{'AttributesRef'},
2277 ARGSRef => $args{'ARGSRef'},
2278 AttributePrefix => $args{'AttributePrefix'},
2286 sub ProcessCustomFieldUpdates {
2288 CustomFieldObj => undef,
2293 my $Object = $args{'CustomFieldObj'};
2294 my $ARGSRef = $args{'ARGSRef'};
2296 my @attribs = qw(Name Type Description Queue SortOrder);
2297 my @results = UpdateRecordObject(
2298 AttributesRef => \@attribs,
2303 my $prefix = "CustomField-" . $Object->Id;
2304 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2305 my ( $addval, $addmsg ) = $Object->AddValue(
2306 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2307 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2308 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2310 push( @results, $addmsg );
2314 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2315 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2316 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2318 foreach my $id (@delete_values) {
2319 next unless defined $id;
2320 my ( $err, $msg ) = $Object->DeleteValue($id);
2321 push( @results, $msg );
2324 my $vals = $Object->Values();
2325 while ( my $cfv = $vals->Next() ) {
2326 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2327 if ( $cfv->SortOrder != $so ) {
2328 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2329 push( @results, $msg );
2339 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2341 Returns an array of results messages.
2345 sub ProcessTicketBasics {
2353 my $TicketObj = $args{'TicketObj'};
2354 my $ARGSRef = $args{'ARGSRef'};
2356 my $OrigOwner = $TicketObj->Owner;
2371 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2372 for my $field (qw(Queue Owner)) {
2373 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2374 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2375 my $temp = $class->new(RT->SystemUser);
2376 $temp->Load( $ARGSRef->{$field} );
2378 $ARGSRef->{$field} = $temp->id;
2383 # Status isn't a field that can be set to a null value.
2384 # RT core complains if you try
2385 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2387 my @results = UpdateRecordObject(
2388 AttributesRef => \@attribs,
2389 Object => $TicketObj,
2390 ARGSRef => $ARGSRef,
2393 # We special case owner changing, so we can use ForceOwnerChange
2394 if ( $ARGSRef->{'Owner'}
2395 && $ARGSRef->{'Owner'} !~ /\D/
2396 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2398 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2399 $ChownType = "Force";
2405 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2406 push( @results, $msg );
2414 sub ProcessTicketReminders {
2421 my $Ticket = $args{'TicketObj'};
2422 my $args = $args{'ARGSRef'};
2425 my $reminder_collection = $Ticket->Reminders->Collection;
2427 if ( $args->{'update-reminders'} ) {
2428 while ( my $reminder = $reminder_collection->Next ) {
2429 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2430 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2431 $Ticket->Reminders->Resolve($reminder);
2433 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2434 $Ticket->Reminders->Open($reminder);
2437 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2438 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2441 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2442 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2445 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2446 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2448 Format => 'unknown',
2449 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2451 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2452 $reminder->SetDue( $DateObj->ISO );
2458 if ( $args->{'NewReminder-Subject'} ) {
2459 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2461 Format => 'unknown',
2462 Value => $args->{'NewReminder-Due'}
2464 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2465 Subject => $args->{'NewReminder-Subject'},
2466 Owner => $args->{'NewReminder-Owner'},
2467 Due => $due_obj->ISO
2469 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2474 sub ProcessTicketCustomFieldUpdates {
2476 $args{'Object'} = delete $args{'TicketObj'};
2477 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2479 # Build up a list of objects that we want to work with
2480 my %custom_fields_to_mod;
2481 foreach my $arg ( keys %$ARGSRef ) {
2482 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2483 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2484 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2485 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2486 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2487 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2491 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2494 sub ProcessObjectCustomFieldUpdates {
2496 my $ARGSRef = $args{'ARGSRef'};
2499 # Build up a list of objects that we want to work with
2500 my %custom_fields_to_mod;
2501 foreach my $arg ( keys %$ARGSRef ) {
2503 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2504 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2506 # For each of those objects, find out what custom fields we want to work with.
2507 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2510 # For each of those objects
2511 foreach my $class ( keys %custom_fields_to_mod ) {
2512 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2513 my $Object = $args{'Object'};
2514 $Object = $class->new( $session{'CurrentUser'} )
2515 unless $Object && ref $Object eq $class;
2517 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2518 unless ( $Object->id ) {
2519 $RT::Logger->warning("Couldn't load object $class #$id");
2523 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2524 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2525 $CustomFieldObj->SetContextObject($Object);
2526 $CustomFieldObj->LoadById($cf);
2527 unless ( $CustomFieldObj->id ) {
2528 $RT::Logger->warning("Couldn't load custom field #$cf");
2532 _ProcessObjectCustomFieldUpdates(
2533 Prefix => "Object-$class-$id-CustomField-$cf-",
2535 CustomField => $CustomFieldObj,
2536 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2544 sub _ProcessObjectCustomFieldUpdates {
2546 my $cf = $args{'CustomField'};
2547 my $cf_type = $cf->Type || '';
2549 # Remove blank Values since the magic field will take care of this. Sometimes
2550 # the browser gives you a blank value which causes CFs to be processed twice
2551 if ( defined $args{'ARGS'}->{'Values'}
2552 && !length $args{'ARGS'}->{'Values'}
2553 && $args{'ARGS'}->{'Values-Magic'} )
2555 delete $args{'ARGS'}->{'Values'};
2559 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2561 # skip category argument
2562 next if $arg eq 'Category';
2565 next if $arg eq 'Value-TimeUnits';
2567 # since http won't pass in a form element with a null value, we need
2569 if ( $arg eq 'Values-Magic' ) {
2571 # We don't care about the magic, if there's really a values element;
2572 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2573 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2575 # "Empty" values does not mean anything for Image and Binary fields
2576 next if $cf_type =~ /^(?:Image|Binary)$/;
2579 $args{'ARGS'}->{'Values'} = undef;
2583 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2584 @values = @{ $args{'ARGS'}->{$arg} };
2585 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2586 @values = ( $args{'ARGS'}->{$arg} );
2588 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2589 if defined $args{'ARGS'}->{$arg};
2591 @values = grep length, map {
2597 grep defined, @values;
2599 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2600 foreach my $value (@values) {
2601 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2605 push( @results, $msg );
2607 } elsif ( $arg eq 'Upload' ) {
2608 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2609 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2610 push( @results, $msg );
2611 } elsif ( $arg eq 'DeleteValues' ) {
2612 foreach my $value (@values) {
2613 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2617 push( @results, $msg );
2619 } elsif ( $arg eq 'DeleteValueIds' ) {
2620 foreach my $value (@values) {
2621 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2625 push( @results, $msg );
2627 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2628 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2631 foreach my $value (@values) {
2632 if ( my $entry = $cf_values->HasEntry($value) ) {
2633 $values_hash{ $entry->id } = 1;
2637 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2641 push( @results, $msg );
2642 $values_hash{$val} = 1 if $val;
2645 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2646 return @results if ( $cf->Type eq 'Date' && ! @values );
2648 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2649 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2651 $cf_values->RedoSearch;
2652 while ( my $cf_value = $cf_values->Next ) {
2653 next if $values_hash{ $cf_value->id };
2655 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2657 ValueId => $cf_value->id
2659 push( @results, $msg );
2661 } elsif ( $arg eq 'Values' ) {
2662 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2664 # keep everything up to the point of difference, delete the rest
2666 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2667 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2676 # now add/replace extra things, if any
2677 foreach my $value (@values) {
2678 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2682 push( @results, $msg );
2687 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2688 $cf->Name, ref $args{'Object'},
2698 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2700 Returns an array of results messages.
2704 sub ProcessTicketWatchers {
2712 my $Ticket = $args{'TicketObj'};
2713 my $ARGSRef = $args{'ARGSRef'};
2717 foreach my $key ( keys %$ARGSRef ) {
2719 # Delete deletable watchers
2720 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2721 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2725 push @results, $msg;
2728 # Delete watchers in the simple style demanded by the bulk manipulator
2729 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2730 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2731 Email => $ARGSRef->{$key},
2734 push @results, $msg;
2737 # Add new wathchers by email address
2738 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2739 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2742 #They're in this order because otherwise $1 gets clobbered :/
2743 my ( $code, $msg ) = $Ticket->AddWatcher(
2744 Type => $ARGSRef->{$key},
2745 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2747 push @results, $msg;
2750 #Add requestors in the simple style demanded by the bulk manipulator
2751 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2752 my ( $code, $msg ) = $Ticket->AddWatcher(
2754 Email => $ARGSRef->{$key}
2756 push @results, $msg;
2759 # Add new watchers by owner
2760 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2761 my $principal_id = $1;
2762 my $form = $ARGSRef->{$key};
2763 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2764 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2766 my ( $code, $msg ) = $Ticket->AddWatcher(
2768 PrincipalId => $principal_id
2770 push @results, $msg;
2780 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2782 Returns an array of results messages.
2786 sub ProcessTicketDates {
2793 my $Ticket = $args{'TicketObj'};
2794 my $ARGSRef = $args{'ARGSRef'};
2799 my @date_fields = qw(
2807 #Run through each field in this list. update the value if apropriate
2808 foreach my $field (@date_fields) {
2809 next unless exists $ARGSRef->{ $field . '_Date' };
2810 next if $ARGSRef->{ $field . '_Date' } eq '';
2814 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2816 Format => 'unknown',
2817 Value => $ARGSRef->{ $field . '_Date' }
2820 my $obj = $field . "Obj";
2821 if ( ( defined $DateObj->Unix )
2822 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2824 my $method = "Set$field";
2825 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2826 push @results, "$msg";
2836 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2838 Returns an array of results messages.
2842 sub ProcessTicketLinks {
2849 my $Ticket = $args{'TicketObj'};
2850 my $ARGSRef = $args{'ARGSRef'};
2852 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2854 #Merge if we need to
2855 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2856 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2857 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2858 push @results, $msg;
2865 sub ProcessRecordLinks {
2872 my $Record = $args{'RecordObj'};
2873 my $ARGSRef = $args{'ARGSRef'};
2877 # Delete links that are gone gone gone.
2878 foreach my $arg ( keys %$ARGSRef ) {
2879 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2884 my ( $val, $msg ) = $Record->DeleteLink(
2890 push @results, $msg;
2896 my @linktypes = qw( DependsOn MemberOf RefersTo );
2898 foreach my $linktype (@linktypes) {
2899 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2900 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2901 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2903 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2905 $luri =~ s/\s+$//; # Strip trailing whitespace
2906 my ( $val, $msg ) = $Record->AddLink(
2910 push @results, $msg;
2913 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2914 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2915 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2917 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2919 my ( $val, $msg ) = $Record->AddLink(
2924 push @results, $msg;
2932 =head2 _UploadedFile ( $arg );
2934 Takes a CGI parameter name; if a file is uploaded under that name,
2935 return a hash reference suitable for AddCustomFieldValue's use:
2936 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2938 Returns C<undef> if no files were uploaded in the C<$arg> field.
2944 my $cgi_object = $m->cgi_object;
2945 my $fh = $cgi_object->upload($arg) or return undef;
2946 my $upload_info = $cgi_object->uploadInfo($fh);
2948 my $filename = "$fh";
2949 $filename =~ s#^.*[\\/]##;
2954 LargeContent => do { local $/; scalar <$fh> },
2955 ContentType => $upload_info->{'Content-Type'},
2959 sub GetColumnMapEntry {
2960 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2962 # deal with the simplest thing first
2963 if ( $args{'Map'}{ $args{'Name'} } ) {
2964 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2968 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2969 return undef unless $args{'Map'}->{$mainkey};
2970 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2971 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2973 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2978 sub ProcessColumnMapValue {
2980 my %args = ( Arguments => [], Escape => 1, @_ );
2983 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2984 my @tmp = $value->( @{ $args{'Arguments'} } );
2985 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2986 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2987 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2988 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2993 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2997 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2999 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3000 principal collections mapped from the categories given.
3004 sub GetPrincipalsMap {
3009 my $system = RT::Groups->new($session{'CurrentUser'});
3010 $system->LimitToSystemInternalGroups();
3011 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3013 'System' => $system, # loc_left_pair
3018 my $groups = RT::Groups->new($session{'CurrentUser'});
3019 $groups->LimitToUserDefinedGroups();
3020 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3022 # Only show groups who have rights granted on this object
3023 $groups->WithGroupRight(
3026 IncludeSystemRights => 0,
3027 IncludeSubgroupMembers => 0,
3031 'User Groups' => $groups, # loc_left_pair
3036 my $roles = RT::Groups->new($session{'CurrentUser'});
3038 if ($object->isa('RT::System')) {
3039 $roles->LimitToRolesForSystem();
3041 elsif ($object->isa('RT::Queue')) {
3042 $roles->LimitToRolesForQueue($object->Id);
3045 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3048 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3050 'Roles' => $roles, # loc_left_pair
3055 my $Users = RT->PrivilegedUsers->UserMembersObj();
3056 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3058 # Only show users who have rights granted on this object
3059 my $group_members = $Users->WhoHaveGroupRight(
3062 IncludeSystemRights => 0,
3063 IncludeSubgroupMembers => 0,
3066 # Limit to UserEquiv groups
3067 my $groups = $Users->NewAlias('Groups');
3071 ALIAS2 => $group_members,
3074 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3075 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3079 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3082 'Users' => $Users, # loc_left_pair
3090 =head2 _load_container_object ( $type, $id );
3092 Instantiate container object for saving searches.
3096 sub _load_container_object {
3097 my ( $obj_type, $obj_id ) = @_;
3098 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3101 =head2 _parse_saved_search ( $arg );
3103 Given a serialization string for saved search, and returns the
3104 container object and the search id.
3108 sub _parse_saved_search {
3110 return unless $spec;
3111 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3118 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3121 =head2 ScrubHTML content
3123 Removes unsafe and undesired HTML from the passed content
3129 my $Content = shift;
3130 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3132 $Content = '' if !defined($Content);
3133 return $SCRUBBER->scrub($Content);
3138 Returns a new L<HTML::Scrubber> object.
3140 If you need to be more lax about what HTML tags and attributes are allowed,
3141 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3144 package HTML::Mason::Commands;
3145 # Let tables through
3146 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3151 our @SCRUBBER_ALLOWED_TAGS = qw(
3152 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3153 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3156 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3157 # Match http, ftp and relative urls
3158 # XXX: we also scrub format strings with this module then allow simple config options
3159 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3165 (?:(?:background-)?color: \s*
3166 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3167 \#[a-f0-9]{3,6} | # #fff or #ffffff
3168 [\w\-]+ # green, light-blue, etc.
3170 text-align: \s* \w+ |
3171 font-size: \s* [\w.\-]+ |
3172 font-family: \s* [\w\s"',.\-]+ |
3173 font-weight: \s* [\w\-]+ |
3175 # MS Office styles, which are probably fine. If we don't, then any
3176 # associated styles in the same attribute get stripped.
3177 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3179 +$ # one or more of these allowed properties from here 'till sunset
3181 dir => qr/^(rtl|ltr)$/i,
3182 lang => qr/^\w+(-\w+)?$/,
3185 our %SCRUBBER_RULES = ();
3188 require HTML::Scrubber;
3189 my $scrubber = HTML::Scrubber->new();
3193 %SCRUBBER_ALLOWED_ATTRIBUTES,
3194 '*' => 0, # require attributes be explicitly allowed
3197 $scrubber->deny(qw[*]);
3198 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3199 $scrubber->rules(%SCRUBBER_RULES);
3201 # Scrubbing comments is vital since IE conditional comments can contain
3202 # arbitrary HTML and we'd pass it right on through.
3203 $scrubber->comment(0);
3210 Redispatches to L<RT::Interface::Web/EncodeJSON>
3215 RT::Interface::Web::EncodeJSON(@_);
3218 package RT::Interface::Web;
3219 RT::Base->_ImportOverlays();