1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2013 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::Session;
74 =head2 EscapeUTF8 SCALARREF
76 does a css-busting but minimalist escaping of whatever html you're passing in.
82 return unless defined $$ref;
87 $$ref =~ s/\(/(/g;
88 $$ref =~ s/\)/)/g;
97 =head2 EscapeURI SCALARREF
99 Escapes URI component according to RFC2396
105 return unless defined $$ref;
108 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
113 sub _encode_surrogates {
114 my $uni = $_[0] - 0x10000;
115 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
120 return unless defined $$ref;
122 $$ref = "'" . join('',
124 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
125 $_ <= 255 ? sprintf("\\x%02X", $_) :
126 $_ <= 65535 ? sprintf("\\u%04X", $_) :
127 sprintf("\\u%X\\u%X", _encode_surrogates($_))
128 } unpack('U*', $$ref))
132 # {{{ WebCanonicalizeInfo
134 =head2 WebCanonicalizeInfo();
136 Different web servers set different environmental varibles. This
137 function must return something suitable for REMOTE_USER. By default,
138 just downcase $ENV{'REMOTE_USER'}
142 sub WebCanonicalizeInfo {
143 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
148 # {{{ WebExternalAutoInfo
150 =head2 WebExternalAutoInfo($user);
152 Returns a hash of user attributes, used when WebExternalAuto is set.
156 sub WebExternalAutoInfo {
161 # default to making Privileged users, even if they specify
162 # some other default Attributes
163 if ( !$RT::AutoCreate
164 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
166 $user_info{'Privileged'} = 1;
169 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
171 # Populate fields with information from Unix /etc/passwd
173 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
174 $user_info{'Comments'} = $comments if defined $comments;
175 $user_info{'RealName'} = $realname if defined $realname;
176 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
178 # Populate fields with information from NT domain controller
181 # and return the wad of stuff
190 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
192 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
194 # Roll back any dangling transactions from a previous failed connection
195 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
197 MaybeEnableSQLStatementLog();
199 # avoid reentrancy, as suggested by masonbook
200 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
202 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
203 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
206 PreprocessTimeUpdates($ARGS);
208 MaybeShowInstallModePage();
210 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
212 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
214 # Process session-related callbacks before any auth attempts
215 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
217 MaybeRejectPrivateComponentRequest();
219 MaybeShowNoAuthPage($ARGS);
221 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
223 _ForceLogout() unless _UserLoggedIn();
225 # Process per-page authentication callbacks
226 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
228 unless ( _UserLoggedIn() ) {
231 # Authenticate if the user is trying to login via user/pass query args
232 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
235 my $m = $HTML::Mason::Commands::m;
237 # REST urls get a special 401 response
238 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
239 $HTML::Mason::Commands::r->content_type("text/plain");
240 $m->error_format("text");
241 $m->out("RT/$RT::VERSION 401 Credentials required\n");
242 $m->out("\n$msg\n") if $msg;
245 # Specially handle /index.html so that we get a nicer URL
246 elsif ( $m->request_comp->path eq '/index.html' ) {
247 my $next = SetNextPage($ARGS);
248 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
252 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
257 MaybeShowInterstitialCSRFPage($ARGS);
259 # now it applies not only to home page, but any dashboard that can be used as a workspace
260 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
261 if ( $ARGS->{'HomeRefreshInterval'} );
263 # Process per-page global callbacks
264 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
266 ShowRequestedPage($ARGS);
267 LogRecordedSQLStatements();
269 # Process per-page final cleanup callbacks
270 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
275 delete $HTML::Mason::Commands::session{'CurrentUser'};
279 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
287 =head2 LoginError ERROR
289 Pushes a login error into the Actions session store and returns the hash key.
295 my $key = Digest::MD5::md5_hex( rand(1024) );
296 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
297 $HTML::Mason::Commands::session{'i'}++;
301 =head2 SetNextPage ARGSRef [PATH]
303 Intuits and stashes the next page in the sesssion hash. If PATH is
304 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
311 my $next = $_[0] ? $_[0] : IntuitNextPage();
312 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
313 my $page = { url => $next };
315 # If an explicit URL was passed and we didn't IntuitNextPage, then
316 # IsPossibleCSRF below is almost certainly unrelated to the actual
317 # destination. Currently explicit next pages aren't used in RT, but the
319 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
320 # This isn't really CSRF, but the CSRF heuristics are useful for catching
321 # requests which may have unintended side-effects.
322 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
325 "Marking original destination as having side-effects before redirecting for login.\n"
327 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
329 $page->{'HasSideEffects'} = [$msg, @loc];
333 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
334 $HTML::Mason::Commands::session{'i'}++;
338 =head2 FetchNextPage HASHKEY
340 Returns the stashed next page hashref for the given hash.
345 my $hash = shift || "";
346 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
349 =head2 RemoveNextPage HASHKEY
351 Removes the stashed next page for the given hash and returns it.
356 my $hash = shift || "";
357 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
360 =head2 TangentForLogin ARGSRef [HASH]
362 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
363 the next page. Takes a hashref of request %ARGS as the first parameter.
364 Optionally takes all other parameters as a hash which is dumped into query
369 sub TangentForLogin {
371 my $hash = SetNextPage($ARGS);
372 my %query = (@_, next => $hash);
373 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
374 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
378 =head2 TangentForLoginWithError ERROR
380 Localizes the passed error message, stashes it with L<LoginError> and then
381 calls L<TangentForLogin> with the appropriate results key.
385 sub TangentForLoginWithError {
387 my $key = LoginError(HTML::Mason::Commands::loc(@_));
388 TangentForLogin( $ARGS, results => $key );
391 =head2 IntuitNextPage
393 Attempt to figure out the path to which we should return the user after a
394 tangent. The current request URL is used, or failing that, the C<WebURL>
395 configuration variable.
402 # This includes any query parameters. Redirect will take care of making
403 # it an absolute URL.
404 if ($ENV{'REQUEST_URI'}) {
405 $req_uri = $ENV{'REQUEST_URI'};
407 # collapse multiple leading slashes so the first part doesn't look like
408 # a hostname of a schema-less URI
409 $req_uri =~ s{^/+}{/};
412 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
415 my $uri = URI->new($next);
417 # You get undef scheme with a relative uri like "/Search/Build.html"
418 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
419 $next = RT->Config->Get('WebURL');
422 # Make sure we're logging in to the same domain
423 # You can get an undef authority with a relative uri like "index.html"
424 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
425 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
426 $next = RT->Config->Get('WebURL');
432 =head2 MaybeShowInstallModePage
434 This function, called exclusively by RT's autohandler, dispatches
435 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
437 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
441 sub MaybeShowInstallModePage {
442 return unless RT->InstallMode;
444 my $m = $HTML::Mason::Commands::m;
445 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
447 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
448 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
455 =head2 MaybeShowNoAuthPage \%ARGS
457 This function, called exclusively by RT's autohandler, dispatches
458 a request to the page a user requested (but only if it matches the "noauth" regex.
460 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
464 sub MaybeShowNoAuthPage {
467 my $m = $HTML::Mason::Commands::m;
469 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
471 # Don't show the login page to logged in users
472 Redirect(RT->Config->Get('WebURL'))
473 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
475 # If it's a noauth file, don't ask for auth.
476 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
480 =head2 MaybeRejectPrivateComponentRequest
482 This function will reject calls to private components, like those under
483 C</Elements>. If the requested path is a private component then we will
484 abort with a C<403> error.
488 sub MaybeRejectPrivateComponentRequest {
489 my $m = $HTML::Mason::Commands::m;
490 my $path = $m->request_comp->path;
492 # We do not check for dhandler here, because requesting our dhandlers
493 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
499 _elements | # mobile UI
502 autohandler | # requesting this directly is suspicious
503 l (_unsafe)? ) # loc component
504 ( $ | / ) # trailing slash or end of path
506 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
509 warn "rejecting private component $path\n";
516 =head2 ShowRequestedPage \%ARGS
518 This function, called exclusively by RT's autohandler, dispatches
519 a request to the page a user requested (making sure that unpriviled users
520 can only see self-service pages.
524 sub ShowRequestedPage {
527 my $m = $HTML::Mason::Commands::m;
529 # Ensure that the cookie that we send is up-to-date, in case the
530 # session-id has been modified in any way
533 # If the user isn't privileged, they can only see SelfService
534 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
536 # if the user is trying to access a ticket, redirect them
537 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
538 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
541 # otherwise, drop the user at the SelfService default page
542 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
543 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
546 # if user is in SelfService dir let him do anything
548 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
551 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
556 sub AttemptExternalAuth {
559 return unless ( RT->Config->Get('WebExternalAuth') );
561 my $user = $ARGS->{user};
562 my $m = $HTML::Mason::Commands::m;
564 # If RT is configured for external auth, let's go through and get REMOTE_USER
566 # do we actually have a REMOTE_USER equivlent?
567 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
568 my $orig_user = $user;
570 $user = RT::Interface::Web::WebCanonicalizeInfo();
571 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
573 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
574 my $NodeName = Win32::NodeName();
575 $user =~ s/^\Q$NodeName\E\\//i;
578 my $next = RemoveNextPage($ARGS->{'next'});
579 $next = $next->{'url'} if ref $next;
580 InstantiateNewSession() unless _UserLoggedIn;
581 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
582 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
584 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
586 # Create users on-the-fly
587 my $UserObj = RT::User->new($RT::SystemUser);
588 my ( $val, $msg ) = $UserObj->Create(
589 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
596 # now get user specific information, to better create our user.
597 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
599 # set the attributes that have been defined.
600 foreach my $attribute ( $UserObj->WritableAttributes ) {
602 Attribute => $attribute,
604 UserInfo => $new_user_info,
605 CallbackName => 'NewUser',
606 CallbackPage => '/autohandler'
608 my $method = "Set$attribute";
609 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
611 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
614 # we failed to successfully create the user. abort abort abort.
615 delete $HTML::Mason::Commands::session{'CurrentUser'};
617 if (RT->Config->Get('WebFallbackToInternalAuth')) {
618 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
625 if ( _UserLoggedIn() ) {
626 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
627 # It is possible that we did a redirect to the login page,
628 # if the external auth allows lack of auth through with no
629 # REMOTE_USER set, instead of forcing a "permission
630 # denied" message. Honor the $next.
631 Redirect($next) if $next;
632 # Unlike AttemptPasswordAuthentication below, we do not
633 # force a redirect to / if $next is not set -- otherwise,
634 # straight-up external auth would always redirect to /
635 # when you first hit it.
637 delete $HTML::Mason::Commands::session{'CurrentUser'};
640 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
641 TangentForLoginWithError($ARGS, 'You are not an authorized user');
644 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
645 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
646 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
647 TangentForLoginWithError($ARGS, 'You are not an authorized user');
651 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
652 # XXX: we must return AUTH_REQUIRED status or we fallback to
653 # internal auth here too.
654 delete $HTML::Mason::Commands::session{'CurrentUser'}
655 if defined $HTML::Mason::Commands::session{'CurrentUser'};
659 sub AttemptPasswordAuthentication {
661 return unless defined $ARGS->{user} && defined $ARGS->{pass};
663 my $user_obj = RT::CurrentUser->new();
664 $user_obj->Load( $ARGS->{user} );
666 my $m = $HTML::Mason::Commands::m;
668 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
669 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
670 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
671 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
674 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
676 # It's important to nab the next page from the session before we blow
678 my $next = RemoveNextPage($ARGS->{'next'});
679 $next = $next->{'url'} if ref $next;
681 InstantiateNewSession();
682 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
684 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
686 # Really the only time we don't want to redirect here is if we were
687 # passed user and pass as query params in the URL.
691 elsif ($ARGS->{'next'}) {
692 # Invalid hash, but still wants to go somewhere, take them to /
693 Redirect(RT->Config->Get('WebURL'));
696 return (1, HTML::Mason::Commands::loc('Logged in'));
700 =head2 LoadSessionFromCookie
702 Load or setup a session cookie for the current user.
706 sub _SessionCookieName {
707 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
708 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
712 sub LoadSessionFromCookie {
714 my %cookies = CGI::Cookie->fetch;
715 my $cookiename = _SessionCookieName();
716 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
717 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
718 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
719 undef $cookies{$cookiename};
721 if ( int RT->Config->Get('AutoLogoff') ) {
722 my $now = int( time / 60 );
723 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
725 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
726 InstantiateNewSession();
729 # save session on each request when AutoLogoff is turned on
730 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
734 sub InstantiateNewSession {
735 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
736 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
740 sub SendSessionCookie {
741 my $cookie = CGI::Cookie->new(
742 -name => _SessionCookieName(),
743 -value => $HTML::Mason::Commands::session{_session_id},
744 -path => RT->Config->Get('WebPath'),
745 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
746 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
749 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
754 This routine ells the current user's browser to redirect to URL.
755 Additionally, it unties the user's currently active session, helping to avoid
756 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
757 a cached DBI statement handle twice at the same time.
762 my $redir_to = shift;
763 untie $HTML::Mason::Commands::session;
764 my $uri = URI->new($redir_to);
765 my $server_uri = URI->new( RT->Config->Get('WebURL') );
767 # Make relative URIs absolute from the server host and scheme
768 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
769 if (not defined $uri->host) {
770 $uri->host($server_uri->host);
771 $uri->port($server_uri->port);
774 # If the user is coming in via a non-canonical
775 # hostname, don't redirect them to the canonical host,
776 # it will just upset them (and invalidate their credentials)
777 # don't do this if $RT::CanoniaclRedirectURLs is true
778 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
779 && $uri->host eq $server_uri->host
780 && $uri->port eq $server_uri->port )
782 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
783 $uri->scheme('https');
785 $uri->scheme('http');
788 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
789 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
790 $uri->port( $ENV{'SERVER_PORT'} );
793 # not sure why, but on some systems without this call mason doesn't
794 # set status to 302, but 200 instead and people see blank pages
795 $HTML::Mason::Commands::r->status(302);
797 # Perlbal expects a status message, but Mason's default redirect status
798 # doesn't provide one. See also rt.cpan.org #36689.
799 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
801 $HTML::Mason::Commands::m->abort;
804 =head2 StaticFileHeaders
806 Send the browser a few headers to try to get it to (somewhat agressively)
807 cache RT's static Javascript and CSS files.
809 This routine could really use _accurate_ heuristics. (XXX TODO)
813 sub StaticFileHeaders {
814 my $date = RT::Date->new($RT::SystemUser);
817 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
819 # remove any cookie headers -- if it is cached publicly, it
820 # shouldn't include anyone's cookie!
821 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
823 # Expire things in a month.
824 $date->Set( Value => time + 30 * 24 * 60 * 60 );
825 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
827 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
828 # request, but we don't handle it and generate full reply again
829 # Last modified at server start time
830 # $date->Set( Value => $^T );
831 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
834 =head2 ComponentPathIsSafe PATH
836 Takes C<PATH> and returns a boolean indicating that the user-specified partial
837 component path is safe.
839 Currently "safe" means that the path does not start with a dot (C<.>), does
840 not contain a slash-dot C</.>, and does not contain any nulls.
844 sub ComponentPathIsSafe {
847 return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
852 Takes a C<< Path => path >> and returns a boolean indicating that
853 the path is safely within RT's control or not. The path I<must> be
856 This function does not consult the filesystem at all; it is merely
857 a logical sanity checking of the path. This explicitly does not handle
858 symlinks; if you have symlinks in RT's webroot pointing outside of it,
859 then we assume you know what you are doing.
866 my $path = $args{Path};
868 # Get File::Spec to clean up extra /s, ./, etc
869 my $cleaned_up = File::Spec->canonpath($path);
871 if (!defined($cleaned_up)) {
872 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
876 # Forbid too many ..s. We can't just sum then check because
877 # "../foo/bar/baz" should be illegal even though it has more
878 # downdirs than updirs. So as soon as we get a negative score
879 # (which means "breaking out" of the top level) we reject the path.
881 my @components = split '/', $cleaned_up;
883 for my $component (@components) {
884 if ($component eq '..') {
887 $RT::Logger->info("Rejecting unsafe path: $path");
891 elsif ($component eq '.' || $component eq '') {
892 # these two have no effect on $score
902 =head2 SendStaticFile
904 Takes a File => path and a Type => Content-type
906 If Type isn't provided and File is an image, it will
907 figure out a sane Content-type, otherwise it will
908 send application/octet-stream
910 Will set caching headers using StaticFileHeaders
917 my $file = $args{File};
918 my $type = $args{Type};
919 my $relfile = $args{RelativeFile};
921 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
922 $HTML::Mason::Commands::r->status(400);
923 $HTML::Mason::Commands::m->abort;
926 $self->StaticFileHeaders();
929 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
931 $type =~ s/jpg/jpeg/gi;
933 $type ||= "application/octet-stream";
936 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
937 # since we don't specify a charset
938 if ( $type =~ m{application/javascript} &&
939 $type !~ m{charset=([\w-]+)$} ) {
940 $type .= "; charset=utf-8";
942 $HTML::Mason::Commands::r->content_type($type);
943 open( my $fh, '<', $file ) or die "couldn't open file: $!";
947 $HTML::Mason::Commands::m->out($_) while (<$fh>);
948 $HTML::Mason::Commands::m->flush_buffer;
955 my $content = $args{Content};
956 return '' unless $content;
958 # Make the content have no 'weird' newlines in it
959 $content =~ s/\r+\n/\n/g;
961 my $return_content = $content;
963 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
964 my $sigonly = $args{StripSignature};
966 # massage content to easily detect if there's any real content
967 $content =~ s/\s+//g; # yes! remove all the spaces
969 # remove html version of spaces and newlines
970 $content =~ s! !!g;
971 $content =~ s!<br/?>!!g;
974 # Filter empty content when type is text/html
975 return '' if $html && $content !~ /\S/;
977 # If we aren't supposed to strip the sig, just bail now.
978 return $return_content unless $sigonly;
981 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
984 # Check for plaintext sig
985 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
987 # Check for html-formatted sig; we don't use EscapeUTF8 here
988 # because we want to precisely match the escaping that FCKEditor
989 # uses. see also 311223f5, which fixed this for 4.0
996 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
999 return $return_content;
1007 # if they've passed multiple values, they'll be an array. if they've
1008 # passed just one, a scalar whatever they are, mark them as utf8
1011 ? Encode::is_utf8($_)
1013 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1014 : ( $type eq 'ARRAY' )
1015 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1017 : ( $type eq 'HASH' )
1018 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1024 sub PreprocessTimeUpdates {
1027 # Later in the code we use
1028 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1029 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1030 # The call_next method pass through original arguments and if you have
1031 # an argument with unicode key then in a next component you'll get two
1032 # records in the args hash: one with key without UTF8 flag and another
1033 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1034 # is copied from mason's source to get the same results as we get from
1035 # call_next method, this feature is not documented, so we just leave it
1036 # here to avoid possible side effects.
1038 # This code canonicalizes time inputs in hours into minutes
1039 foreach my $field ( keys %$ARGS ) {
1040 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1042 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1043 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1044 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1045 $ARGS->{$local} *= 60;
1047 delete $ARGS->{$field};
1052 sub MaybeEnableSQLStatementLog {
1054 my $log_sql_statements = RT->Config->Get('StatementLog');
1056 if ($log_sql_statements) {
1057 $RT::Handle->ClearSQLStatementLog;
1058 $RT::Handle->LogSQLStatements(1);
1063 sub LogRecordedSQLStatements {
1064 my $log_sql_statements = RT->Config->Get('StatementLog');
1066 return unless ($log_sql_statements);
1068 my @log = $RT::Handle->SQLStatementLog;
1069 $RT::Handle->ClearSQLStatementLog;
1070 for my $stmt (@log) {
1071 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1081 level => $log_sql_statements,
1083 . sprintf( "%.6f", $duration )
1085 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
1091 our %is_whitelisted_component = (
1092 # The RSS feed embeds an auth token in the path, but query
1093 # information for the search. Because it's a straight-up read, in
1094 # addition to embedding its own auth, it's fine.
1095 '/NoAuth/rss/dhandler' => 1,
1097 # IE doesn't send referer in window.open()
1098 # besides, as a harmless calendar select page, it's fine
1099 '/Helpers/CalPopup.html' => 1,
1101 # While both of these can be used for denial-of-service against RT
1102 # (construct a very inefficient query and trick lots of users into
1103 # running them against RT) it's incredibly useful to be able to link
1104 # to a search result or bookmark a result page.
1105 '/Search/Results.html' => 1,
1106 '/Search/Simple.html' => 1,
1109 # Components which are blacklisted from automatic, argument-based whitelisting.
1110 # These pages are not idempotent when called with just an id.
1111 our %is_blacklisted_component = (
1112 # Takes only id and toggles bookmark state
1113 '/Helpers/Toggle/TicketBookmark' => 1,
1116 sub IsCompCSRFWhitelisted {
1120 return 1 if $is_whitelisted_component{$comp};
1122 my %args = %{ $ARGS };
1124 # If the user specifies a *correct* user and pass then they are
1125 # golden. This acts on the presumption that external forms may
1126 # hardcode a username and password -- if a malicious attacker knew
1127 # both already, CSRF is the least of your problems.
1128 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1129 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1130 my $user_obj = RT::CurrentUser->new();
1131 $user_obj->Load($args{user});
1132 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1138 # Some pages aren't idempotent even with safe args like id; blacklist
1139 # them from the automatic whitelisting below.
1140 return 0 if $is_blacklisted_component{$comp};
1142 # Eliminate arguments that do not indicate an effectful request.
1143 # For example, "id" is acceptable because that is how RT retrieves a
1147 # If they have a valid results= from MaybeRedirectForResults, that's
1149 delete $args{results} if $args{results}
1150 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1152 # The homepage refresh, which uses the Refresh header, doesn't send
1153 # a referer in most browsers; whitelist the one parameter it reloads
1154 # with, HomeRefreshInterval, which is safe
1155 delete $args{HomeRefreshInterval};
1157 # If there are no arguments, then it's likely to be an idempotent
1158 # request, which are not susceptible to CSRF
1164 sub IsRefererCSRFWhitelisted {
1165 my $referer = _NormalizeHost(shift);
1166 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1167 $base_url = $base_url->host_port;
1170 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1171 push @$configs,$config;
1172 return 1 if $referer->host_port eq $config;
1175 return (0,$referer,$configs);
1178 =head3 _NormalizeHost
1180 Takes a URI and creates a URI object that's been normalized
1181 to handle common problems such as localhost vs 127.0.0.1
1185 sub _NormalizeHost {
1187 my $uri= URI->new(shift);
1188 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1194 sub IsPossibleCSRF {
1197 # If first request on this session is to a REST endpoint, then
1198 # whitelist the REST endpoints -- and explicitly deny non-REST
1199 # endpoints. We do this because using a REST cookie in a browser
1200 # would open the user to CSRF attacks to the REST endpoints.
1201 my $comp = $HTML::Mason::Commands::m->request_comp->path;
1202 $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1203 unless defined $HTML::Mason::Commands::session{'REST'};
1205 if ($HTML::Mason::Commands::session{'REST'}) {
1206 return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1208 This login session belongs to a REST client, and cannot be used to
1209 access non-REST interfaces of RT for security reasons.
1211 my $details = <<EOT;
1212 Please log out and back in to obtain a session for normal browsing. If
1213 you understand the security implications, disabling RT's CSRF protection
1214 will remove this restriction.
1217 HTML::Mason::Commands::Abort( $why, Details => $details );
1220 return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1222 # if there is no Referer header then assume the worst
1224 "your browser did not supply a Referrer header", # loc
1225 ) if !$ENV{HTTP_REFERER};
1227 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1228 return 0 if $whitelisted;
1230 if ( @$configs > 1 ) {
1232 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1233 $browser->host_port,
1235 join(', ', @$configs) );
1239 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1240 $browser->host_port,
1244 sub ExpandCSRFToken {
1247 my $token = delete $ARGS->{CSRF_Token};
1248 return unless $token;
1250 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1251 return unless $data;
1252 return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1254 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1255 return unless $user->ValidateAuthString( $data->{auth}, $token );
1257 %{$ARGS} = %{$data->{args}};
1259 # We explicitly stored file attachments with the request, but not in
1260 # the session yet, as that would itself be an attack. Put them into
1261 # the session now, so they'll be visible.
1262 if ($data->{attach}) {
1263 my $filename = $data->{attach}{filename};
1264 my $mime = $data->{attach}{mime};
1265 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1272 sub StoreRequestToken {
1275 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1276 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1278 auth => $user->GenerateAuthString( $token ),
1279 uri => $HTML::Mason::Commands::r->uri,
1282 if ($ARGS->{Attach}) {
1283 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1284 my $file_path = delete $ARGS->{'Attach'};
1286 filename => Encode::decode_utf8("$file_path"),
1287 mime => $attachment,
1291 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1292 $HTML::Mason::Commands::session{'i'}++;
1296 sub MaybeShowInterstitialCSRFPage {
1299 return unless RT->Config->Get('RestrictReferrer');
1301 # Deal with the form token provided by the interstitial, which lets
1302 # browsers which never set referer headers still use RT, if
1303 # painfully. This blows values into ARGS
1304 return if ExpandCSRFToken($ARGS);
1306 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1307 return if !$is_csrf;
1309 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1311 my $token = StoreRequestToken($ARGS);
1312 $HTML::Mason::Commands::m->comp(
1314 OriginalURL => $HTML::Mason::Commands::r->uri,
1315 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1318 # Calls abort, never gets here
1321 our @POTENTIAL_PAGE_ACTIONS = (
1322 qr'/Ticket/Create.html' => "create a ticket", # loc
1323 qr'/Ticket/' => "update a ticket", # loc
1324 qr'/Admin/' => "modify RT's configuration", # loc
1325 qr'/Approval/' => "update an approval", # loc
1326 qr'/Dashboards/' => "modify a dashboard", # loc
1327 qr'/m/ticket/' => "update a ticket", # loc
1328 qr'Prefs' => "modify your preferences", # loc
1329 qr'/Search/' => "modify or access a search", # loc
1330 qr'/SelfService/Create' => "create a ticket", # loc
1331 qr'/SelfService/' => "update a ticket", # loc
1334 sub PotentialPageAction {
1336 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1337 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1338 return HTML::Mason::Commands::loc($result)
1339 if $page =~ $pattern;
1344 package HTML::Mason::Commands;
1346 use vars qw/$r $m %session/;
1352 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1353 with whatever it's called with. If there is no $session{'CurrentUser'},
1354 it creates a temporary user, so we have something to get a localisation handle
1361 if ( $session{'CurrentUser'}
1362 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1364 return ( $session{'CurrentUser'}->loc(@_) );
1367 RT::CurrentUser->new();
1371 return ( $u->loc(@_) );
1374 # pathetic case -- SystemUser is gone.
1383 =head2 loc_fuzzy STRING
1385 loc_fuzzy is for handling localizations of messages that may already
1386 contain interpolated variables, typically returned from libraries
1387 outside RT's control. It takes the message string and extracts the
1388 variable array automatically by matching against the candidate entries
1389 inside the lexicon file.
1396 if ( $session{'CurrentUser'}
1397 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1399 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1401 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1402 return ( $u->loc_fuzzy($msg) );
1409 # Error - calls Error and aborts
1414 if ( $session{'ErrorDocument'}
1415 && $session{'ErrorDocumentType'} )
1417 $r->content_type( $session{'ErrorDocumentType'} );
1418 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1421 $m->comp( "/Elements/Error", Why => $why, %args );
1428 # {{{ sub CreateTicket
1430 =head2 CreateTicket ARGS
1432 Create a new ticket, using Mason's %ARGS. returns @results.
1441 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1443 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1444 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1445 Abort('Queue not found');
1448 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1449 Abort('You have no permission to create tickets in that queue.');
1453 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1454 $due = new RT::Date( $session{'CurrentUser'} );
1455 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1458 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1459 $starts = new RT::Date( $session{'CurrentUser'} );
1460 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1463 my $sigless = RT::Interface::Web::StripContent(
1464 Content => $ARGS{Content},
1465 ContentType => $ARGS{ContentType},
1466 StripSignature => 1,
1467 CurrentUser => $session{'CurrentUser'},
1470 my $MIMEObj = MakeMIMEEntity(
1471 Subject => $ARGS{'Subject'},
1472 From => $ARGS{'From'},
1475 Type => $ARGS{'ContentType'},
1478 if ( $ARGS{'Attachments'} ) {
1479 my $rv = $MIMEObj->make_multipart;
1480 $RT::Logger->error("Couldn't make multipart message")
1481 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1483 foreach ( values %{ $ARGS{'Attachments'} } ) {
1485 $RT::Logger->error("Couldn't add empty attachemnt");
1488 $MIMEObj->add_part($_);
1492 for my $argument (qw(Encrypt Sign)) {
1493 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1497 Type => $ARGS{'Type'} || 'ticket',
1498 Queue => $ARGS{'Queue'},
1499 Owner => $ARGS{'Owner'},
1502 Requestor => $ARGS{'Requestors'},
1504 AdminCc => $ARGS{'AdminCc'},
1505 InitialPriority => $ARGS{'InitialPriority'},
1506 FinalPriority => $ARGS{'FinalPriority'},
1507 TimeLeft => $ARGS{'TimeLeft'},
1508 TimeEstimated => $ARGS{'TimeEstimated'},
1509 TimeWorked => $ARGS{'TimeWorked'},
1510 Subject => $ARGS{'Subject'},
1511 Status => $ARGS{'Status'},
1512 Due => $due ? $due->ISO : undef,
1513 Starts => $starts ? $starts->ISO : undef,
1518 foreach my $type (qw(Requestor Cc AdminCc)) {
1519 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1520 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1524 if (@temp_squelch) {
1525 require RT::Action::SendEmail;
1526 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1529 if ( $ARGS{'AttachTickets'} ) {
1530 require RT::Action::SendEmail;
1531 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1532 ref $ARGS{'AttachTickets'}
1533 ? @{ $ARGS{'AttachTickets'} }
1534 : ( $ARGS{'AttachTickets'} ) );
1537 foreach my $arg ( keys %ARGS ) {
1538 next if $arg =~ /-(?:Magic|Category)$/;
1540 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1541 $create_args{$arg} = $ARGS{$arg};
1544 # Object-RT::Ticket--CustomField-3-Values
1545 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1548 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1549 $cf->SetContextObject( $Queue );
1551 unless ( $cf->id ) {
1552 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1556 if ( $arg =~ /-Upload$/ ) {
1557 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1561 my $type = $cf->Type;
1564 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1565 @values = @{ $ARGS{$arg} };
1566 } elsif ( $type =~ /text/i ) {
1567 @values = ( $ARGS{$arg} );
1569 no warnings 'uninitialized';
1570 @values = split /\r*\n/, $ARGS{$arg};
1572 @values = grep length, map {
1578 grep defined, @values;
1580 $create_args{"CustomField-$cfid"} = \@values;
1584 # turn new link lists into arrays, and pass in the proper arguments
1586 'new-DependsOn' => 'DependsOn',
1587 'DependsOn-new' => 'DependedOnBy',
1588 'new-MemberOf' => 'Parents',
1589 'MemberOf-new' => 'Children',
1590 'new-RefersTo' => 'RefersTo',
1591 'RefersTo-new' => 'ReferredToBy',
1593 foreach my $key ( keys %map ) {
1594 next unless $ARGS{$key};
1595 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1599 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1604 push( @Actions, split( "\n", $ErrMsg ) );
1605 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1606 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1608 return ( $Ticket, @Actions );
1614 # {{{ sub LoadTicket - loads a ticket
1616 =head2 LoadTicket id
1618 Takes a ticket id as its only variable. if it's handed an array, it takes
1621 Returns an RT::Ticket object as the current user.
1628 if ( ref($id) eq "ARRAY" ) {
1633 Abort("No ticket specified");
1636 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1638 unless ( $Ticket->id ) {
1639 Abort("Could not load ticket $id");
1646 # {{{ sub ProcessUpdateMessage
1648 =head2 ProcessUpdateMessage
1650 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1652 Don't write message if it only contains current user's signature and
1653 SkipSignatureOnly argument is true. Function anyway adds attachments
1654 and updates time worked field even if skips message. The default value
1659 sub ProcessUpdateMessage {
1664 SkipSignatureOnly => 1,
1668 if ( $args{ARGSRef}->{'UpdateAttachments'}
1669 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1671 delete $args{ARGSRef}->{'UpdateAttachments'};
1674 # Strip the signature
1675 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1676 Content => $args{ARGSRef}->{UpdateContent},
1677 ContentType => $args{ARGSRef}->{UpdateContentType},
1678 StripSignature => $args{SkipSignatureOnly},
1679 CurrentUser => $args{'TicketObj'}->CurrentUser,
1682 my %txn_customfields;
1684 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1685 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1686 next if $key =~ /(TimeUnits|Magic)$/;
1687 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1691 # If, after stripping the signature, we have no message, create a
1692 # Touch transaction if necessary
1693 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1694 and not length $args{ARGSRef}->{'UpdateContent'} )
1696 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1697 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1698 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1701 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1702 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1703 my ( $Transaction, $Description, $Object ) =
1704 $args{TicketObj}->Touch(
1705 CustomFields => \%txn_customfields,
1706 TimeTaken => $timetaken
1708 return $Description;
1713 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1714 $args{ARGSRef}->{'UpdateSubject'} = undef;
1717 my $Message = MakeMIMEEntity(
1718 Subject => $args{ARGSRef}->{'UpdateSubject'},
1719 Body => $args{ARGSRef}->{'UpdateContent'},
1720 Type => $args{ARGSRef}->{'UpdateContentType'},
1723 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1724 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1726 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1727 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1728 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1730 $old_txn = $args{TicketObj}->Transactions->First();
1733 if ( my $msg = $old_txn->Message->First ) {
1734 RT::Interface::Email::SetInReplyTo(
1735 Message => $Message,
1740 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1741 $Message->make_multipart;
1742 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1745 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1746 require RT::Action::SendEmail;
1747 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1748 ref $args{ARGSRef}->{'AttachTickets'}
1749 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1750 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1753 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1754 my $cc = $args{ARGSRef}->{'UpdateCc'};
1756 my %message_args = (
1758 BccMessageTo => $bcc,
1759 Sign => $args{ARGSRef}->{'Sign'},
1760 Encrypt => $args{ARGSRef}->{'Encrypt'},
1761 MIMEObj => $Message,
1762 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1763 CustomFields => \%txn_customfields,
1767 foreach my $type (qw(Cc AdminCc)) {
1768 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1769 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1770 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1771 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1774 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1775 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1776 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1779 if (@temp_squelch) {
1780 require RT::Action::SendEmail;
1781 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1784 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1785 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1786 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1788 my $var = ucfirst($1) . 'MessageTo';
1790 if ( $message_args{$var} ) {
1791 $message_args{$var} .= ", $value";
1793 $message_args{$var} = $value;
1799 # Do the update via the appropriate Ticket method
1800 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1801 my ( $Transaction, $Description, $Object ) =
1802 $args{TicketObj}->Comment(%message_args);
1803 push( @results, $Description );
1804 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1805 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1806 my ( $Transaction, $Description, $Object ) =
1807 $args{TicketObj}->Correspond(%message_args);
1808 push( @results, $Description );
1809 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1812 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1819 # {{{ sub MakeMIMEEntity
1821 =head2 MakeMIMEEntity PARAMHASH
1823 Takes a paramhash Subject, Body and AttachmentFieldName.
1825 Also takes Form, Cc and Type as optional paramhash keys.
1827 Returns a MIME::Entity.
1831 sub MakeMIMEEntity {
1833 #TODO document what else this takes.
1839 AttachmentFieldName => undef,
1843 my $Message = MIME::Entity->build(
1844 Type => 'multipart/mixed',
1845 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1846 grep defined $args{$_}, qw(Subject From Cc)
1849 if ( defined $args{'Body'} && length $args{'Body'} ) {
1851 # Make the update content have no 'weird' newlines in it
1852 $args{'Body'} =~ s/\r\n/\n/gs;
1855 Type => $args{'Type'} || 'text/plain',
1857 Data => $args{'Body'},
1861 if ( $args{'AttachmentFieldName'} ) {
1863 my $cgi_object = $m->cgi_object;
1865 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1867 my ( @content, $buffer );
1868 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1869 push @content, $buffer;
1872 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1874 # Prefer the cached name first over CGI.pm stringification.
1875 my $filename = $RT::Mason::CGI::Filename;
1876 $filename = "$filehandle" unless defined $filename;
1877 $filename = Encode::encode_utf8( $filename );
1878 $filename =~ s{^.*[\\/]}{};
1881 Type => $uploadinfo->{'Content-Type'},
1882 Filename => $filename,
1885 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1886 $Message->head->set( 'Subject' => $filename );
1891 $Message->make_singlepart;
1893 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1901 # {{{ sub ParseDateToISO
1903 =head2 ParseDateToISO
1905 Takes a date in an arbitrary format.
1906 Returns an ISO date and time in GMT
1910 sub ParseDateToISO {
1913 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1915 Format => 'unknown',
1918 return ( $date_obj->ISO );
1923 # {{{ sub ProcessACLChanges
1925 sub ProcessACLChanges {
1926 my $ARGSref = shift;
1930 foreach my $arg ( keys %$ARGSref ) {
1931 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1933 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1936 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1937 @rights = @{ $ARGSref->{$arg} };
1939 @rights = $ARGSref->{$arg};
1941 @rights = grep $_, @rights;
1942 next unless @rights;
1944 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1945 $principal->Load($principal_id);
1948 if ( $object_type eq 'RT::System' ) {
1950 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1951 $obj = $object_type->new( $session{'CurrentUser'} );
1952 $obj->Load($object_id);
1953 unless ( $obj->id ) {
1954 $RT::Logger->error("couldn't load $object_type #$object_id");
1958 $RT::Logger->error("object type '$object_type' is incorrect");
1959 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1963 foreach my $right (@rights) {
1964 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1965 push( @results, $msg );
1974 # {{{ sub UpdateRecordObj
1976 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1978 @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.
1980 Returns an array of success/failure messages
1984 sub UpdateRecordObject {
1987 AttributesRef => undef,
1989 AttributePrefix => undef,
1993 my $Object = $args{'Object'};
1994 my @results = $Object->Update(
1995 AttributesRef => $args{'AttributesRef'},
1996 ARGSRef => $args{'ARGSRef'},
1997 AttributePrefix => $args{'AttributePrefix'},
2005 # {{{ Sub ProcessCustomFieldUpdates
2007 sub ProcessCustomFieldUpdates {
2009 CustomFieldObj => undef,
2014 my $Object = $args{'CustomFieldObj'};
2015 my $ARGSRef = $args{'ARGSRef'};
2017 my @attribs = qw(Name Type Description Queue SortOrder);
2018 my @results = UpdateRecordObject(
2019 AttributesRef => \@attribs,
2024 my $prefix = "CustomField-" . $Object->Id;
2025 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2026 my ( $addval, $addmsg ) = $Object->AddValue(
2027 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2028 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2029 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2031 push( @results, $addmsg );
2035 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2036 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2037 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2039 foreach my $id (@delete_values) {
2040 next unless defined $id;
2041 my ( $err, $msg ) = $Object->DeleteValue($id);
2042 push( @results, $msg );
2045 my $vals = $Object->Values();
2046 while ( my $cfv = $vals->Next() ) {
2047 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2048 if ( $cfv->SortOrder != $so ) {
2049 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2050 push( @results, $msg );
2060 # {{{ sub ProcessTicketBasics
2062 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2064 Returns an array of results messages.
2068 sub ProcessTicketBasics {
2076 my $TicketObj = $args{'TicketObj'};
2077 my $ARGSRef = $args{'ARGSRef'};
2079 # {{{ Set basic fields
2092 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
2093 my $tempqueue = RT::Queue->new($RT::SystemUser);
2094 $tempqueue->Load( $ARGSRef->{'Queue'} );
2095 if ( $tempqueue->id ) {
2096 $ARGSRef->{'Queue'} = $tempqueue->id;
2100 # Status isn't a field that can be set to a null value.
2101 # RT core complains if you try
2102 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2104 my @results = UpdateRecordObject(
2105 AttributesRef => \@attribs,
2106 Object => $TicketObj,
2107 ARGSRef => $ARGSRef,
2110 # We special case owner changing, so we can use ForceOwnerChange
2111 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2113 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2114 $ChownType = "Force";
2116 $ChownType = "Give";
2119 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2120 push( @results, $msg );
2130 sub ProcessTicketCustomFieldUpdates {
2132 $args{'Object'} = delete $args{'TicketObj'};
2133 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2135 # Build up a list of objects that we want to work with
2136 my %custom_fields_to_mod;
2137 foreach my $arg ( keys %$ARGSRef ) {
2138 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2139 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2140 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2141 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2142 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2143 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2147 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2150 sub ProcessObjectCustomFieldUpdates {
2152 my $ARGSRef = $args{'ARGSRef'};
2155 # Build up a list of objects that we want to work with
2156 my %custom_fields_to_mod;
2157 foreach my $arg ( keys %$ARGSRef ) {
2159 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2160 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2162 # For each of those objects, find out what custom fields we want to work with.
2163 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2166 # For each of those objects
2167 foreach my $class ( keys %custom_fields_to_mod ) {
2168 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2169 my $Object = $args{'Object'};
2170 $Object = $class->new( $session{'CurrentUser'} )
2171 unless $Object && ref $Object eq $class;
2173 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2174 unless ( $Object->id ) {
2175 $RT::Logger->warning("Couldn't load object $class #$id");
2179 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2180 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2181 $CustomFieldObj->SetContextObject($Object);
2182 $CustomFieldObj->LoadById($cf);
2183 unless ( $CustomFieldObj->id ) {
2184 $RT::Logger->warning("Couldn't load custom field #$cf");
2188 _ProcessObjectCustomFieldUpdates(
2189 Prefix => "Object-$class-$id-CustomField-$cf-",
2191 CustomField => $CustomFieldObj,
2192 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2200 sub _ProcessObjectCustomFieldUpdates {
2202 my $cf = $args{'CustomField'};
2203 my $cf_type = $cf->Type;
2205 # Remove blank Values since the magic field will take care of this. Sometimes
2206 # the browser gives you a blank value which causes CFs to be processed twice
2207 if ( defined $args{'ARGS'}->{'Values'}
2208 && !length $args{'ARGS'}->{'Values'}
2209 && $args{'ARGS'}->{'Values-Magic'} )
2211 delete $args{'ARGS'}->{'Values'};
2215 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2217 # skip category argument
2218 next if $arg eq 'Category';
2221 next if $arg eq 'Value-TimeUnits';
2223 # since http won't pass in a form element with a null value, we need
2225 if ( $arg eq 'Values-Magic' ) {
2227 # We don't care about the magic, if there's really a values element;
2228 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2229 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2231 # "Empty" values does not mean anything for Image and Binary fields
2232 next if $cf_type =~ /^(?:Image|Binary)$/;
2235 $args{'ARGS'}->{'Values'} = undef;
2239 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2240 @values = @{ $args{'ARGS'}->{$arg} };
2241 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2242 @values = ( $args{'ARGS'}->{$arg} );
2244 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2245 if defined $args{'ARGS'}->{$arg};
2247 @values = grep length, map {
2253 grep defined, @values;
2255 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2256 foreach my $value (@values) {
2257 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2261 push( @results, $msg );
2263 } elsif ( $arg eq 'Upload' ) {
2264 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2265 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2266 push( @results, $msg );
2267 } elsif ( $arg eq 'DeleteValues' ) {
2268 foreach my $value (@values) {
2269 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2273 push( @results, $msg );
2275 } elsif ( $arg eq 'DeleteValueIds' ) {
2276 foreach my $value (@values) {
2277 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2281 push( @results, $msg );
2283 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2284 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2287 foreach my $value (@values) {
2288 if ( my $entry = $cf_values->HasEntry($value) ) {
2289 $values_hash{ $entry->id } = 1;
2293 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2297 push( @results, $msg );
2298 $values_hash{$val} = 1 if $val;
2301 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2302 return @results if ( $cf->Type eq 'Date' && ! @values );
2304 $cf_values->RedoSearch;
2305 while ( my $cf_value = $cf_values->Next ) {
2306 next if $values_hash{ $cf_value->id };
2308 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2310 ValueId => $cf_value->id
2312 push( @results, $msg );
2314 } elsif ( $arg eq 'Values' ) {
2315 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2317 # keep everything up to the point of difference, delete the rest
2319 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2320 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2329 # now add/replace extra things, if any
2330 foreach my $value (@values) {
2331 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2335 push( @results, $msg );
2340 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2341 $cf->Name, ref $args{'Object'},
2350 # {{{ sub ProcessTicketWatchers
2352 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2354 Returns an array of results messages.
2358 sub ProcessTicketWatchers {
2366 my $Ticket = $args{'TicketObj'};
2367 my $ARGSRef = $args{'ARGSRef'};
2371 foreach my $key ( keys %$ARGSRef ) {
2373 # Delete deletable watchers
2374 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2375 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2379 push @results, $msg;
2382 # Delete watchers in the simple style demanded by the bulk manipulator
2383 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2384 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2385 Email => $ARGSRef->{$key},
2388 push @results, $msg;
2391 # Add new wathchers by email address
2392 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2393 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2396 #They're in this order because otherwise $1 gets clobbered :/
2397 my ( $code, $msg ) = $Ticket->AddWatcher(
2398 Type => $ARGSRef->{$key},
2399 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2401 push @results, $msg;
2404 #Add requestors in the simple style demanded by the bulk manipulator
2405 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2406 my ( $code, $msg ) = $Ticket->AddWatcher(
2408 Email => $ARGSRef->{$key}
2410 push @results, $msg;
2413 # Add new watchers by owner
2414 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2415 my $principal_id = $1;
2416 my $form = $ARGSRef->{$key};
2417 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2418 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2420 my ( $code, $msg ) = $Ticket->AddWatcher(
2422 PrincipalId => $principal_id
2424 push @results, $msg;
2434 # {{{ sub ProcessTicketDates
2436 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2438 Returns an array of results messages.
2442 sub ProcessTicketDates {
2449 my $Ticket = $args{'TicketObj'};
2450 my $ARGSRef = $args{'ARGSRef'};
2454 # {{{ Set date fields
2455 my @date_fields = qw(
2463 #Run through each field in this list. update the value if apropriate
2464 foreach my $field (@date_fields) {
2465 next unless exists $ARGSRef->{ $field . '_Date' };
2466 next if $ARGSRef->{ $field . '_Date' } eq '';
2470 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2472 Format => 'unknown',
2473 Value => $ARGSRef->{ $field . '_Date' }
2476 my $obj = $field . "Obj";
2477 if ( ( defined $DateObj->Unix )
2478 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2480 my $method = "Set$field";
2481 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2482 push @results, "$msg";
2492 # {{{ sub ProcessTicketLinks
2494 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2496 Returns an array of results messages.
2500 sub ProcessTicketLinks {
2507 my $Ticket = $args{'TicketObj'};
2508 my $ARGSRef = $args{'ARGSRef'};
2510 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2512 #Merge if we need to
2513 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2514 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2515 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2516 push @results, $msg;
2524 sub ProcessRecordLinks {
2531 my $Record = $args{'RecordObj'};
2532 my $ARGSRef = $args{'ARGSRef'};
2536 # Delete links that are gone gone gone.
2537 foreach my $arg ( keys %$ARGSRef ) {
2538 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2543 my ( $val, $msg ) = $Record->DeleteLink(
2549 push @results, $msg;
2555 my @linktypes = qw( DependsOn MemberOf RefersTo );
2557 foreach my $linktype (@linktypes) {
2558 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2559 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2560 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2562 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2564 $luri =~ s/\s+$//; # Strip trailing whitespace
2565 my ( $val, $msg ) = $Record->AddLink(
2569 push @results, $msg;
2572 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2573 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2574 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2576 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2578 my ( $val, $msg ) = $Record->AddLink(
2583 push @results, $msg;
2591 =head2 _UploadedFile ( $arg );
2593 Takes a CGI parameter name; if a file is uploaded under that name,
2594 return a hash reference suitable for AddCustomFieldValue's use:
2595 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2597 Returns C<undef> if no files were uploaded in the C<$arg> field.
2603 my $cgi_object = $m->cgi_object;
2604 my $fh = $cgi_object->upload($arg) or return undef;
2605 my $upload_info = $cgi_object->uploadInfo($fh);
2607 my $filename = "$fh";
2608 $filename =~ s#^.*[\\/]##;
2613 LargeContent => do { local $/; scalar <$fh> },
2614 ContentType => $upload_info->{'Content-Type'},
2618 sub GetColumnMapEntry {
2619 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2621 # deal with the simplest thing first
2622 if ( $args{'Map'}{ $args{'Name'} } ) {
2623 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2627 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2628 return undef unless $args{'Map'}->{$mainkey};
2629 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2630 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2632 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2637 sub ProcessColumnMapValue {
2639 my %args = ( Arguments => [], Escape => 1, @_ );
2642 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2643 my @tmp = $value->( @{ $args{'Arguments'} } );
2644 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2645 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2646 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2647 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2652 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2656 =head2 _load_container_object ( $type, $id );
2658 Instantiate container object for saving searches.
2662 sub _load_container_object {
2663 my ( $obj_type, $obj_id ) = @_;
2664 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2667 =head2 _parse_saved_search ( $arg );
2669 Given a serialization string for saved search, and returns the
2670 container object and the search id.
2674 sub _parse_saved_search {
2676 return unless $spec;
2677 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2684 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2687 =head2 ScrubHTML content
2689 Removes unsafe and undesired HTML from the passed content
2695 my $Content = shift;
2696 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2698 $Content = '' if !defined($Content);
2699 return $SCRUBBER->scrub($Content);
2704 Returns a new L<HTML::Scrubber> object.
2706 If you need to be more lax about what HTML tags and attributes are allowed,
2707 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2710 package HTML::Mason::Commands;
2711 # Let tables through
2712 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2717 our @SCRUBBER_ALLOWED_TAGS = qw(
2718 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2719 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2722 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2723 # Match http, ftp and relative urls
2724 # XXX: we also scrub format strings with this module then allow simple config options
2725 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2731 (?:(?:background-)?color: \s*
2732 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2733 \#[a-f0-9]{3,6} | # #fff or #ffffff
2734 [\w\-]+ # green, light-blue, etc.
2736 text-align: \s* \w+ |
2737 font-size: \s* [\w.\-]+ |
2738 font-family: \s* [\w\s"',.\-]+ |
2739 font-weight: \s* [\w\-]+ |
2741 # MS Office styles, which are probably fine. If we don't, then any
2742 # associated styles in the same attribute get stripped.
2743 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2745 +$ # one or more of these allowed properties from here 'till sunset
2749 our %SCRUBBER_RULES = ();
2752 require HTML::Scrubber;
2753 my $scrubber = HTML::Scrubber->new();
2757 %SCRUBBER_ALLOWED_ATTRIBUTES,
2758 '*' => 0, # require attributes be explicitly allowed
2761 $scrubber->deny(qw[*]);
2762 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2763 $scrubber->rules(%SCRUBBER_RULES);
2765 # Scrubbing comments is vital since IE conditional comments can contain
2766 # arbitrary HTML and we'd pass it right on through.
2767 $scrubber->comment(0);
2772 package RT::Interface::Web;
2773 RT::Base->_ImportOverlays();