Upgrade to 4.0.8 with mod of ExternalAuth + absolute paths to ticket-menu.
[usit-rt.git] / lib / RT / Interface / Web.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
5# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
6# <sales@bestpractical.com>
7#
8# (Except where explicitly superseded by other copyright notices)
9#
10#
11# LICENSE:
12#
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
16# from www.gnu.org.
17#
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.
22#
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.
28#
29#
30# CONTRIBUTION SUBMISSION POLICY:
31#
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.)
37#
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.
46#
47# END BPS TAGGED BLOCK }}}
48
49## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
50
51## This is a library of static subs to be used by the Mason web
52## interface to RT
53
54=head1 NAME
55
56RT::Interface::Web
57
58
59=cut
60
61use strict;
62use warnings;
63
64package RT::Interface::Web;
65
66use RT::SavedSearches;
67use URI qw();
68use RT::Interface::Web::Menu;
69use RT::Interface::Web::Session;
70use Digest::MD5 ();
71use Encode qw();
72use List::MoreUtils qw();
73use JSON qw();
74
75=head2 SquishedCSS $style
76
77=cut
78
79my %SQUISHED_CSS;
80sub SquishedCSS {
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;
86 return $css;
87}
88
89=head2 SquishedJS
90
91=cut
92
93my $SQUISHED_JS;
94sub SquishedJS {
95 return $SQUISHED_JS if $SQUISHED_JS;
96
97 require RT::Squish::JS;
98 my $js = RT::Squish::JS->new();
99 $SQUISHED_JS = $js;
100 return $js;
101}
102
103=head2 ClearSquished
104
105Removes the cached CSS and JS entries, forcing them to be regenerated
106on next use.
107
108=cut
109
110sub ClearSquished {
111 undef $SQUISHED_JS;
112 %SQUISHED_CSS = ();
113}
114
115=head2 EscapeUTF8 SCALARREF
116
117does a css-busting but minimalist escaping of whatever html you're passing in.
118
119=cut
120
121sub EscapeUTF8 {
122 my $ref = shift;
123 return unless defined $$ref;
124
125 $$ref =~ s/&/&#38;/g;
126 $$ref =~ s/</&lt;/g;
127 $$ref =~ s/>/&gt;/g;
128 $$ref =~ s/\(/&#40;/g;
129 $$ref =~ s/\)/&#41;/g;
130 $$ref =~ s/"/&#34;/g;
131 $$ref =~ s/'/&#39;/g;
132}
133
134
135
136=head2 EscapeURI SCALARREF
137
138Escapes URI component according to RFC2396
139
140=cut
141
142sub EscapeURI {
143 my $ref = shift;
144 return unless defined $$ref;
145
146 use bytes;
147 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
148}
149
150=head2 EncodeJSON SCALAR
151
152Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
153value or a reference.
154
155=cut
156
157sub EncodeJSON {
158 JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
159}
160
161sub _encode_surrogates {
162 my $uni = $_[0] - 0x10000;
163 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
164}
165
166sub EscapeJS {
167 my $ref = shift;
168 return unless defined $$ref;
169
170 $$ref = "'" . join('',
171 map {
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))
177 . "'";
178}
179
180=head2 WebCanonicalizeInfo();
181
182Different web servers set different environmental varibles. This
183function must return something suitable for REMOTE_USER. By default,
184just downcase $ENV{'REMOTE_USER'}
185
186=cut
187
188sub WebCanonicalizeInfo {
189 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
190}
191
192
193
194=head2 WebExternalAutoInfo($user);
195
196Returns a hash of user attributes, used when WebExternalAuto is set.
197
198=cut
199
200sub WebExternalAutoInfo {
201 my $user = shift;
202
203 my %user_info;
204
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} ) )
209 {
210 $user_info{'Privileged'} = 1;
211 }
212
213 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
214
215 # Populate fields with information from Unix /etc/passwd
216
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' ) {
221
222 # Populate fields with information from NT domain controller
223 }
224
225 # and return the wad of stuff
226 return {%user_info};
227}
228
229
230sub HandleRequest {
231 my $ARGS = shift;
232
233 if (RT->Config->Get('DevelMode')) {
234 require Module::Refresh;
235 Module::Refresh->refresh;
236 }
237
238 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
239
240 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
241
242 # Roll back any dangling transactions from a previous failed connection
243 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
244
245 MaybeEnableSQLStatementLog();
246
247 # avoid reentrancy, as suggested by masonbook
248 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
249
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') );
252
253 ValidateWebConfig();
254
255 DecodeARGS($ARGS);
b5747ff2 256 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
84fb5b46
MKG
257 PreprocessTimeUpdates($ARGS);
258
259 InitializeMenu();
260 MaybeShowInstallModePage();
261
262 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
263 SendSessionCookie();
dab09ea8
MKG
264
265 if ( _UserLoggedIn() ) {
266 # make user info up to date
267 $HTML::Mason::Commands::session{'CurrentUser'}
268 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
269 }
270 else {
271 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
272 }
84fb5b46
MKG
273
274 # Process session-related callbacks before any auth attempts
275 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
276
277 MaybeRejectPrivateComponentRequest();
278
279 MaybeShowNoAuthPage($ARGS);
280
281 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
282
283 _ForceLogout() unless _UserLoggedIn();
284
285 # Process per-page authentication callbacks
286 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
287
288 unless ( _UserLoggedIn() ) {
289 _ForceLogout();
290
291 # Authenticate if the user is trying to login via user/pass query args
292 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
293
294 unless ($authed) {
295 my $m = $HTML::Mason::Commands::m;
296
297 # REST urls get a special 401 response
dab09ea8 298 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
84fb5b46
MKG
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;
303 $m->abort;
304 }
305 # Specially handle /index.html so that we get a nicer URL
306 elsif ( $m->request_comp->path eq '/index.html' ) {
dab09ea8 307 my $next = SetNextPage($ARGS);
84fb5b46
MKG
308 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
309 $m->abort;
310 }
311 else {
dab09ea8 312 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
84fb5b46
MKG
313 }
314 }
315 }
316
317 MaybeShowInterstitialCSRFPage($ARGS);
318
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'} );
322
323 # Process per-page global callbacks
324 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
325
326 ShowRequestedPage($ARGS);
327 LogRecordedSQLStatements(RequestData => {
328 Path => $HTML::Mason::Commands::m->request_comp->path,
329 });
330
331 # Process per-page final cleanup callbacks
332 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
333
334 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS );
335}
336
337sub _ForceLogout {
338
339 delete $HTML::Mason::Commands::session{'CurrentUser'};
340}
341
342sub _UserLoggedIn {
343 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
344 return 1;
345 } else {
346 return undef;
347 }
348
349}
350
351=head2 LoginError ERROR
352
353Pushes a login error into the Actions session store and returns the hash key.
354
355=cut
356
357sub LoginError {
358 my $new = shift;
359 my $key = Digest::MD5::md5_hex( rand(1024) );
360 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
361 $HTML::Mason::Commands::session{'i'}++;
362 return $key;
363}
364
dab09ea8 365=head2 SetNextPage ARGSRef [PATH]
84fb5b46
MKG
366
367Intuits and stashes the next page in the sesssion hash. If PATH is
368specified, uses that instead of the value of L<IntuitNextPage()>. Returns
369the hash value.
370
371=cut
372
373sub SetNextPage {
dab09ea8
MKG
374 my $ARGS = shift;
375 my $next = $_[0] ? $_[0] : IntuitNextPage();
84fb5b46 376 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
dab09ea8
MKG
377 my $page = { url => $next };
378
379 # If an explicit URL was passed and we didn't IntuitNextPage, then
380 # IsPossibleCSRF below is almost certainly unrelated to the actual
381 # destination. Currently explicit next pages aren't used in RT, but the
382 # API is available.
383 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
384 # This isn't really CSRF, but the CSRF heuristics are useful for catching
385 # requests which may have unintended side-effects.
386 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
387 if ($is_csrf) {
388 RT->Logger->notice(
389 "Marking original destination as having side-effects before redirecting for login.\n"
390 ."Request: $next\n"
391 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
392 );
393 $page->{'HasSideEffects'} = [$msg, @loc];
394 }
395 }
84fb5b46 396
dab09ea8 397 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
84fb5b46
MKG
398 $HTML::Mason::Commands::session{'i'}++;
399 return $hash;
400}
401
dab09ea8
MKG
402=head2 FetchNextPage HASHKEY
403
404Returns the stashed next page hashref for the given hash.
405
406=cut
407
408sub FetchNextPage {
409 my $hash = shift || "";
410 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
411}
412
413=head2 RemoveNextPage HASHKEY
414
415Removes the stashed next page for the given hash and returns it.
416
417=cut
418
419sub RemoveNextPage {
420 my $hash = shift || "";
421 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
422}
84fb5b46 423
dab09ea8 424=head2 TangentForLogin ARGSRef [HASH]
84fb5b46
MKG
425
426Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
dab09ea8
MKG
427the next page. Takes a hashref of request %ARGS as the first parameter.
428Optionally takes all other parameters as a hash which is dumped into query
429params.
84fb5b46
MKG
430
431=cut
432
433sub TangentForLogin {
dab09ea8
MKG
434 my $ARGS = shift;
435 my $hash = SetNextPage($ARGS);
84fb5b46
MKG
436 my %query = (@_, next => $hash);
437 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
438 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
439 Redirect($login);
440}
441
442=head2 TangentForLoginWithError ERROR
443
444Localizes the passed error message, stashes it with L<LoginError> and then
445calls L<TangentForLogin> with the appropriate results key.
446
447=cut
448
449sub TangentForLoginWithError {
dab09ea8
MKG
450 my $ARGS = shift;
451 my $key = LoginError(HTML::Mason::Commands::loc(@_));
452 TangentForLogin( $ARGS, results => $key );
84fb5b46
MKG
453}
454
455=head2 IntuitNextPage
456
457Attempt to figure out the path to which we should return the user after a
458tangent. The current request URL is used, or failing that, the C<WebURL>
459configuration variable.
460
461=cut
462
463sub IntuitNextPage {
464 my $req_uri;
465
466 # This includes any query parameters. Redirect will take care of making
467 # it an absolute URL.
468 if ($ENV{'REQUEST_URI'}) {
469 $req_uri = $ENV{'REQUEST_URI'};
470
471 # collapse multiple leading slashes so the first part doesn't look like
472 # a hostname of a schema-less URI
473 $req_uri =~ s{^/+}{/};
474 }
475
476 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
477
478 # sanitize $next
479 my $uri = URI->new($next);
480
481 # You get undef scheme with a relative uri like "/Search/Build.html"
482 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
483 $next = RT->Config->Get('WebURL');
484 }
485
486 # Make sure we're logging in to the same domain
487 # You can get an undef authority with a relative uri like "index.html"
488 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
489 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
490 $next = RT->Config->Get('WebURL');
491 }
492
493 return $next;
494}
495
496=head2 MaybeShowInstallModePage
497
498This function, called exclusively by RT's autohandler, dispatches
499a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
500
501If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
502
503=cut
504
505sub MaybeShowInstallModePage {
506 return unless RT->InstallMode;
507
508 my $m = $HTML::Mason::Commands::m;
509 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
510 $m->call_next();
dab09ea8 511 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
84fb5b46
MKG
512 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
513 } else {
514 $m->call_next();
515 }
516 $m->abort();
517}
518
519=head2 MaybeShowNoAuthPage \%ARGS
520
521This function, called exclusively by RT's autohandler, dispatches
522a request to the page a user requested (but only if it matches the "noauth" regex.
523
524If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
525
526=cut
527
528sub MaybeShowNoAuthPage {
529 my $ARGS = shift;
530
531 my $m = $HTML::Mason::Commands::m;
532
533 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
534
535 # Don't show the login page to logged in users
536 Redirect(RT->Config->Get('WebURL'))
537 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
538
539 # If it's a noauth file, don't ask for auth.
540 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
541 $m->abort;
542}
543
544=head2 MaybeRejectPrivateComponentRequest
545
546This function will reject calls to private components, like those under
547C</Elements>. If the requested path is a private component then we will
548abort with a C<403> error.
549
550=cut
551
552sub MaybeRejectPrivateComponentRequest {
553 my $m = $HTML::Mason::Commands::m;
554 my $path = $m->request_comp->path;
555
556 # We do not check for dhandler here, because requesting our dhandlers
557 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
558 # 'dhandler'.
559
560 if ($path =~ m{
561 / # leading slash
562 ( Elements |
563 _elements | # mobile UI
564 Widgets |
565 autohandler | # requesting this directly is suspicious
566 l (_unsafe)? ) # loc component
567 ( $ | / ) # trailing slash or end of path
568 }xi) {
569 $m->abort(403);
570 }
571
572 return;
573}
574
575sub InitializeMenu {
576 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
577 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
578 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
579
580}
581
582
583=head2 ShowRequestedPage \%ARGS
584
585This function, called exclusively by RT's autohandler, dispatches
586a request to the page a user requested (making sure that unpriviled users
587can only see self-service pages.
588
589=cut
590
591sub ShowRequestedPage {
592 my $ARGS = shift;
593
594 my $m = $HTML::Mason::Commands::m;
595
b5747ff2
MKG
596 # Ensure that the cookie that we send is up-to-date, in case the
597 # session-id has been modified in any way
598 SendSessionCookie();
599
84fb5b46
MKG
600 # precache all system level rights for the current user
601 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
602
603 # If the user isn't privileged, they can only see SelfService
604 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
605
606 # if the user is trying to access a ticket, redirect them
dab09ea8 607 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
84fb5b46
MKG
608 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
609 }
610
611 # otherwise, drop the user at the SelfService default page
612 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
613 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
614 }
615
616 # if user is in SelfService dir let him do anything
617 else {
618 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
619 }
620 } else {
621 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
622 }
623
624}
625
626sub AttemptExternalAuth {
627 my $ARGS = shift;
628
629 return unless ( RT->Config->Get('WebExternalAuth') );
630
631 my $user = $ARGS->{user};
632 my $m = $HTML::Mason::Commands::m;
633
634 # If RT is configured for external auth, let's go through and get REMOTE_USER
635
636 # do we actually have a REMOTE_USER equivlent?
637 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
638 my $orig_user = $user;
639
640 $user = RT::Interface::Web::WebCanonicalizeInfo();
641 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
642
643 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
644 my $NodeName = Win32::NodeName();
645 $user =~ s/^\Q$NodeName\E\\//i;
646 }
647
dab09ea8
MKG
648 my $next = RemoveNextPage($ARGS->{'next'});
649 $next = $next->{'url'} if ref $next;
84fb5b46
MKG
650 InstantiateNewSession() unless _UserLoggedIn;
651 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
652 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
653
654 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
655
656 # Create users on-the-fly
657 my $UserObj = RT::User->new(RT->SystemUser);
658 my ( $val, $msg ) = $UserObj->Create(
659 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
660 Name => $user,
661 Gecos => $user,
662 );
663
664 if ($val) {
665
666 # now get user specific information, to better create our user.
667 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
668
669 # set the attributes that have been defined.
670 foreach my $attribute ( $UserObj->WritableAttributes ) {
671 $m->callback(
672 Attribute => $attribute,
673 User => $user,
674 UserInfo => $new_user_info,
675 CallbackName => 'NewUser',
676 CallbackPage => '/autohandler'
677 );
678 my $method = "Set$attribute";
679 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
680 }
681 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
682 } else {
683
684 # we failed to successfully create the user. abort abort abort.
685 delete $HTML::Mason::Commands::session{'CurrentUser'};
686
687 if (RT->Config->Get('WebFallbackToInternalAuth')) {
dab09ea8 688 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
84fb5b46
MKG
689 } else {
690 $m->abort();
691 }
692 }
693 }
694
695 if ( _UserLoggedIn() ) {
696 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
697 # It is possible that we did a redirect to the login page,
698 # if the external auth allows lack of auth through with no
699 # REMOTE_USER set, instead of forcing a "permission
700 # denied" message. Honor the $next.
701 Redirect($next) if $next;
702 # Unlike AttemptPasswordAuthentication below, we do not
703 # force a redirect to / if $next is not set -- otherwise,
704 # straight-up external auth would always redirect to /
705 # when you first hit it.
706 } else {
707 delete $HTML::Mason::Commands::session{'CurrentUser'};
708 $user = $orig_user;
709
dab09ea8
MKG
710 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
711 TangentForLoginWithError($ARGS, 'You are not an authorized user');
84fb5b46
MKG
712 }
713 }
714 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
715 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
716 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
dab09ea8 717 TangentForLoginWithError($ARGS, 'You are not an authorized user');
84fb5b46
MKG
718 }
719 } else {
720
721 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
722 # XXX: we must return AUTH_REQUIRED status or we fallback to
723 # internal auth here too.
724 delete $HTML::Mason::Commands::session{'CurrentUser'}
725 if defined $HTML::Mason::Commands::session{'CurrentUser'};
726 }
727}
728
729sub AttemptPasswordAuthentication {
730 my $ARGS = shift;
731 return unless defined $ARGS->{user} && defined $ARGS->{pass};
732
733 my $user_obj = RT::CurrentUser->new();
734 $user_obj->Load( $ARGS->{user} );
735
736 my $m = $HTML::Mason::Commands::m;
737
738 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
739 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
740 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
741 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
742 }
743 else {
744 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
745
746 # It's important to nab the next page from the session before we blow
747 # the session away
dab09ea8
MKG
748 my $next = RemoveNextPage($ARGS->{'next'});
749 $next = $next->{'url'} if ref $next;
84fb5b46
MKG
750
751 InstantiateNewSession();
752 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
84fb5b46
MKG
753
754 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
755
756 # Really the only time we don't want to redirect here is if we were
757 # passed user and pass as query params in the URL.
758 if ($next) {
759 Redirect($next);
760 }
761 elsif ($ARGS->{'next'}) {
762 # Invalid hash, but still wants to go somewhere, take them to /
763 Redirect(RT->Config->Get('WebURL'));
764 }
765
766 return (1, HTML::Mason::Commands::loc('Logged in'));
767 }
768}
769
770=head2 LoadSessionFromCookie
771
772Load or setup a session cookie for the current user.
773
774=cut
775
776sub _SessionCookieName {
777 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
778 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
779 return $cookiename;
780}
781
782sub LoadSessionFromCookie {
783
784 my %cookies = CGI::Cookie->fetch;
785 my $cookiename = _SessionCookieName();
786 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
787 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
788 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
789 undef $cookies{$cookiename};
790 }
791 if ( int RT->Config->Get('AutoLogoff') ) {
792 my $now = int( time / 60 );
793 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
794
795 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
796 InstantiateNewSession();
797 }
798
799 # save session on each request when AutoLogoff is turned on
800 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
801 }
802}
803
804sub InstantiateNewSession {
805 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
806 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
b5747ff2 807 SendSessionCookie();
84fb5b46
MKG
808}
809
810sub SendSessionCookie {
811 my $cookie = CGI::Cookie->new(
812 -name => _SessionCookieName(),
813 -value => $HTML::Mason::Commands::session{_session_id},
814 -path => RT->Config->Get('WebPath'),
815 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
816 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
817 );
818
819 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
820}
821
822=head2 Redirect URL
823
824This routine ells the current user's browser to redirect to URL.
825Additionally, it unties the user's currently active session, helping to avoid
826A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
827a cached DBI statement handle twice at the same time.
828
829=cut
830
831sub Redirect {
832 my $redir_to = shift;
833 untie $HTML::Mason::Commands::session;
834 my $uri = URI->new($redir_to);
835 my $server_uri = URI->new( RT->Config->Get('WebURL') );
836
837 # Make relative URIs absolute from the server host and scheme
838 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
839 if (not defined $uri->host) {
840 $uri->host($server_uri->host);
841 $uri->port($server_uri->port);
842 }
843
844 # If the user is coming in via a non-canonical
845 # hostname, don't redirect them to the canonical host,
846 # it will just upset them (and invalidate their credentials)
847 # don't do this if $RT::CanonicalizeRedirectURLs is true
848 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
849 && $uri->host eq $server_uri->host
850 && $uri->port eq $server_uri->port )
851 {
852 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
853 $uri->scheme('https');
854 } else {
855 $uri->scheme('http');
856 }
857
858 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
859 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
860 $uri->port( $ENV{'SERVER_PORT'} );
861 }
862
863 # not sure why, but on some systems without this call mason doesn't
864 # set status to 302, but 200 instead and people see blank pages
865 $HTML::Mason::Commands::r->status(302);
866
867 # Perlbal expects a status message, but Mason's default redirect status
868 # doesn't provide one. See also rt.cpan.org #36689.
869 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
870
871 $HTML::Mason::Commands::m->abort;
872}
873
874=head2 StaticFileHeaders
875
876Send the browser a few headers to try to get it to (somewhat agressively)
877cache RT's static Javascript and CSS files.
878
879This routine could really use _accurate_ heuristics. (XXX TODO)
880
881=cut
882
883sub StaticFileHeaders {
884 my $date = RT::Date->new(RT->SystemUser);
885
886 # make cache public
887 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
888
889 # remove any cookie headers -- if it is cached publicly, it
890 # shouldn't include anyone's cookie!
891 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
892
893 # Expire things in a month.
894 $date->Set( Value => time + 30 * 24 * 60 * 60 );
895 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
896
897 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
898 # request, but we don't handle it and generate full reply again
899 # Last modified at server start time
900 # $date->Set( Value => $^T );
901 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
902}
903
904=head2 ComponentPathIsSafe PATH
905
906Takes C<PATH> and returns a boolean indicating that the user-specified partial
907component path is safe.
908
909Currently "safe" means that the path does not start with a dot (C<.>) and does
910not contain a slash-dot C</.>.
911
912=cut
913
914sub ComponentPathIsSafe {
915 my $self = shift;
916 my $path = shift;
917 return $path !~ m{(?:^|/)\.};
918}
919
920=head2 PathIsSafe
921
922Takes a C<< Path => path >> and returns a boolean indicating that
923the path is safely within RT's control or not. The path I<must> be
924relative.
925
926This function does not consult the filesystem at all; it is merely
927a logical sanity checking of the path. This explicitly does not handle
928symlinks; if you have symlinks in RT's webroot pointing outside of it,
929then we assume you know what you are doing.
930
931=cut
932
933sub PathIsSafe {
934 my $self = shift;
935 my %args = @_;
936 my $path = $args{Path};
937
938 # Get File::Spec to clean up extra /s, ./, etc
939 my $cleaned_up = File::Spec->canonpath($path);
940
941 if (!defined($cleaned_up)) {
942 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
943 return 0;
944 }
945
946 # Forbid too many ..s. We can't just sum then check because
947 # "../foo/bar/baz" should be illegal even though it has more
948 # downdirs than updirs. So as soon as we get a negative score
949 # (which means "breaking out" of the top level) we reject the path.
950
951 my @components = split '/', $cleaned_up;
952 my $score = 0;
953 for my $component (@components) {
954 if ($component eq '..') {
955 $score--;
956 if ($score < 0) {
957 $RT::Logger->info("Rejecting unsafe path: $path");
958 return 0;
959 }
960 }
961 elsif ($component eq '.' || $component eq '') {
962 # these two have no effect on $score
963 }
964 else {
965 $score++;
966 }
967 }
968
969 return 1;
970}
971
972=head2 SendStaticFile
973
974Takes a File => path and a Type => Content-type
975
976If Type isn't provided and File is an image, it will
977figure out a sane Content-type, otherwise it will
978send application/octet-stream
979
980Will set caching headers using StaticFileHeaders
981
982=cut
983
984sub SendStaticFile {
985 my $self = shift;
986 my %args = @_;
987 my $file = $args{File};
988 my $type = $args{Type};
989 my $relfile = $args{RelativeFile};
990
991 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
992 $HTML::Mason::Commands::r->status(400);
993 $HTML::Mason::Commands::m->abort;
994 }
995
996 $self->StaticFileHeaders();
997
998 unless ($type) {
999 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1000 $type = "image/$1";
1001 $type =~ s/jpg/jpeg/gi;
1002 }
1003 $type ||= "application/octet-stream";
1004 }
1005 $HTML::Mason::Commands::r->content_type($type);
1006 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1007 binmode($fh);
1008 {
1009 local $/ = \16384;
1010 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1011 $HTML::Mason::Commands::m->flush_buffer;
1012 }
1013 close $fh;
1014}
1015
1016
1017
1018sub MobileClient {
1019 my $self = shift;
1020
1021
dab09ea8 1022if (($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'}) {
84fb5b46
MKG
1023 return 1;
1024} else {
1025 return undef;
1026}
1027
1028}
1029
1030
1031sub StripContent {
1032 my %args = @_;
1033 my $content = $args{Content};
1034 return '' unless $content;
1035
1036 # Make the content have no 'weird' newlines in it
1037 $content =~ s/\r+\n/\n/g;
1038
1039 my $return_content = $content;
1040
1041 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1042 my $sigonly = $args{StripSignature};
1043
1044 # massage content to easily detect if there's any real content
1045 $content =~ s/\s+//g; # yes! remove all the spaces
1046 if ( $html ) {
1047 # remove html version of spaces and newlines
1048 $content =~ s!&nbsp;!!g;
1049 $content =~ s!<br/?>!!g;
1050 }
1051
1052 # Filter empty content when type is text/html
1053 return '' if $html && $content !~ /\S/;
1054
1055 # If we aren't supposed to strip the sig, just bail now.
1056 return $return_content unless $sigonly;
1057
1058 # Find the signature
1059 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1060 $sig =~ s/\s+//g;
1061
1062 # Check for plaintext sig
1063 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1064
1065 # Check for html-formatted sig; we don't use EscapeUTF8 here
1066 # because we want to precisely match the escapting that FCKEditor
1067 # uses.
1068 $sig =~ s/&/&amp;/g;
1069 $sig =~ s/</&lt;/g;
1070 $sig =~ s/>/&gt;/g;
1071 $sig =~ s/"/&quot;/g;
1072 $sig =~ s/'/&#39;/g;
1073 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1074
1075 # Pass it through
1076 return $return_content;
1077}
1078
1079sub DecodeARGS {
1080 my $ARGS = shift;
1081
1082 %{$ARGS} = map {
1083
1084 # if they've passed multiple values, they'll be an array. if they've
1085 # passed just one, a scalar whatever they are, mark them as utf8
1086 my $type = ref($_);
1087 ( !$type )
1088 ? Encode::is_utf8($_)
1089 ? $_
1090 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1091 : ( $type eq 'ARRAY' )
1092 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1093 @$_ ]
1094 : ( $type eq 'HASH' )
1095 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1096 %$_ }
1097 : $_
1098 } %$ARGS;
1099}
1100
1101sub PreprocessTimeUpdates {
1102 my $ARGS = shift;
1103
1104 # Later in the code we use
1105 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1106 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1107 # The call_next method pass through original arguments and if you have
1108 # an argument with unicode key then in a next component you'll get two
1109 # records in the args hash: one with key without UTF8 flag and another
1110 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1111 # is copied from mason's source to get the same results as we get from
1112 # call_next method, this feature is not documented, so we just leave it
1113 # here to avoid possible side effects.
1114
1115 # This code canonicalizes time inputs in hours into minutes
1116 foreach my $field ( keys %$ARGS ) {
1117 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1118 my $local = $1;
1119 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1120 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1121 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1122 $ARGS->{$local} *= 60;
1123 }
1124 delete $ARGS->{$field};
1125 }
1126
1127}
1128
1129sub MaybeEnableSQLStatementLog {
1130
1131 my $log_sql_statements = RT->Config->Get('StatementLog');
1132
1133 if ($log_sql_statements) {
1134 $RT::Handle->ClearSQLStatementLog;
1135 $RT::Handle->LogSQLStatements(1);
1136 }
1137
1138}
1139
1140sub LogRecordedSQLStatements {
1141 my %args = @_;
1142
1143 my $log_sql_statements = RT->Config->Get('StatementLog');
1144
1145 return unless ($log_sql_statements);
1146
1147 my @log = $RT::Handle->SQLStatementLog;
1148 $RT::Handle->ClearSQLStatementLog;
1149
1150 $RT::Handle->AddRequestToHistory({
1151 %{ $args{RequestData} },
1152 Queries => \@log,
1153 });
1154
1155 for my $stmt (@log) {
1156 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1157 my @bind;
1158 if ( ref $bind ) {
1159 @bind = @{$bind};
1160 } else {
1161
1162 # Older DBIx-SB
1163 $duration = $bind;
1164 }
1165 $RT::Logger->log(
1166 level => $log_sql_statements,
1167 message => "SQL("
1168 . sprintf( "%.6f", $duration )
1169 . "s): $sql;"
1170 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1171 );
1172 }
1173
1174}
1175
1176my $_has_validated_web_config = 0;
1177sub ValidateWebConfig {
1178 my $self = shift;
1179
1180 # do this once per server instance, not once per request
1181 return if $_has_validated_web_config;
1182 $_has_validated_web_config = 1;
1183
1184 if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) {
1185 $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.");
1186 }
1187
1188 if ($ENV{HTTP_HOST}) {
1189 # match "example.com" or "example.com:80"
1190 my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/;
1191
1192 if ($host ne RT->Config->Get('WebDomain')) {
1193 $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.");
1194 }
1195 }
1196 else {
1197 if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) {
1198 $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.");
1199 }
1200 }
1201
1202 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1203 $RT::Logger->warn("The actual SCRIPT_NAME ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1204 }
1205}
1206
1207sub ComponentRoots {
1208 my $self = shift;
1209 my %args = ( Names => 0, @_ );
1210 my @roots;
1211 if (defined $HTML::Mason::Commands::m) {
1212 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1213 } else {
1214 @roots = (
1215 [ local => $RT::MasonLocalComponentRoot ],
1216 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1217 [ standard => $RT::MasonComponentRoot ]
1218 );
1219 }
1220 @roots = map { $_->[1] } @roots unless $args{Names};
1221 return @roots;
1222}
1223
b5747ff2 1224our %is_whitelisted_component = (
84fb5b46
MKG
1225 # The RSS feed embeds an auth token in the path, but query
1226 # information for the search. Because it's a straight-up read, in
1227 # addition to embedding its own auth, it's fine.
1228 '/NoAuth/rss/dhandler' => 1,
dab09ea8
MKG
1229
1230 # While these can be used for denial-of-service against RT
1231 # (construct a very inefficient query and trick lots of users into
1232 # running them against RT) it's incredibly useful to be able to link
1233 # to a search result or bookmark a result page.
1234 '/Search/Results.html' => 1,
1235 '/Search/Simple.html' => 1,
1236 '/m/tickets/search' => 1,
1237);
1238
1239# Components which are blacklisted from automatic, argument-based whitelisting.
1240# These pages are not idempotent when called with just an id.
1241our %is_blacklisted_component = (
1242 # Takes only id and toggles bookmark state
1243 '/Helpers/Toggle/TicketBookmark' => 1,
84fb5b46
MKG
1244);
1245
1246sub IsCompCSRFWhitelisted {
1247 my $comp = shift;
1248 my $ARGS = shift;
1249
b5747ff2 1250 return 1 if $is_whitelisted_component{$comp};
84fb5b46
MKG
1251
1252 my %args = %{ $ARGS };
1253
1254 # If the user specifies a *correct* user and pass then they are
1255 # golden. This acts on the presumption that external forms may
1256 # hardcode a username and password -- if a malicious attacker knew
1257 # both already, CSRF is the least of your problems.
1258 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1259 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1260 my $user_obj = RT::CurrentUser->new();
1261 $user_obj->Load($args{user});
1262 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1263
1264 delete $args{user};
1265 delete $args{pass};
1266 }
1267
dab09ea8
MKG
1268 # Some pages aren't idempotent even with safe args like id; blacklist
1269 # them from the automatic whitelisting below.
1270 return 0 if $is_blacklisted_component{$comp};
1271
84fb5b46
MKG
1272 # Eliminate arguments that do not indicate an effectful request.
1273 # For example, "id" is acceptable because that is how RT retrieves a
1274 # record.
1275 delete $args{id};
1276
1277 # If they have a valid results= from MaybeRedirectForResults, that's
1278 # also fine.
1279 delete $args{results} if $args{results}
1280 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1281
b5747ff2
MKG
1282 # The homepage refresh, which uses the Refresh header, doesn't send
1283 # a referer in most browsers; whitelist the one parameter it reloads
1284 # with, HomeRefreshInterval, which is safe
1285 delete $args{HomeRefreshInterval};
1286
84fb5b46
MKG
1287 # If there are no arguments, then it's likely to be an idempotent
1288 # request, which are not susceptible to CSRF
1289 return 1 if !%args;
1290
1291 return 0;
1292}
1293
1294sub IsRefererCSRFWhitelisted {
1295 my $referer = _NormalizeHost(shift);
b5747ff2
MKG
1296 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1297 $base_url = $base_url->host_port;
84fb5b46 1298
b5747ff2
MKG
1299 my $configs;
1300 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1301 push @$configs,$config;
dab09ea8
MKG
1302
1303 my $host_port = $referer->host_port;
1304 if ($config =~ /\*/) {
1305 # Turn a literal * into a domain component or partial component match.
1306 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1307 my $regex = join "[a-zA-Z0-9\-]*",
1308 map { quotemeta($_) }
1309 split /\*/, $config;
1310
1311 return 1 if $host_port =~ /^$regex$/i;
1312 } else {
1313 return 1 if $host_port eq $config;
1314 }
b5747ff2 1315 }
84fb5b46 1316
b5747ff2 1317 return (0,$referer,$configs);
84fb5b46
MKG
1318}
1319
1320=head3 _NormalizeHost
1321
1322Takes a URI and creates a URI object that's been normalized
1323to handle common problems such as localhost vs 127.0.0.1
1324
1325=cut
1326
1327sub _NormalizeHost {
1328
1329 my $uri= URI->new(shift);
1330 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1331
1332 return $uri;
1333
1334}
1335
1336sub IsPossibleCSRF {
1337 my $ARGS = shift;
1338
1339 # If first request on this session is to a REST endpoint, then
1340 # whitelist the REST endpoints -- and explicitly deny non-REST
1341 # endpoints. We do this because using a REST cookie in a browser
1342 # would open the user to CSRF attacks to the REST endpoints.
1343 my $path = $HTML::Mason::Commands::r->path_info;
1344 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1345 unless defined $HTML::Mason::Commands::session{'REST'};
1346
1347 if ($HTML::Mason::Commands::session{'REST'}) {
1348 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1349 my $why = <<EOT;
1350This login session belongs to a REST client, and cannot be used to
1351access non-REST interfaces of RT for security reasons.
1352EOT
1353 my $details = <<EOT;
1354Please log out and back in to obtain a session for normal browsing. If
1355you understand the security implications, disabling RT's CSRF protection
1356will remove this restriction.
1357EOT
1358 chomp $details;
1359 HTML::Mason::Commands::Abort( $why, Details => $details );
1360 }
1361
1362 return 0 if IsCompCSRFWhitelisted(
1363 $HTML::Mason::Commands::m->request_comp->path,
1364 $ARGS
1365 );
1366
1367 # if there is no Referer header then assume the worst
1368 return (1,
1369 "your browser did not supply a Referrer header", # loc
1370 ) if !$ENV{HTTP_REFERER};
1371
b5747ff2 1372 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
84fb5b46
MKG
1373 return 0 if $whitelisted;
1374
b5747ff2
MKG
1375 if ( @$configs > 1 ) {
1376 return (1,
1377 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1378 $browser->host_port,
1379 shift @$configs,
1380 join(', ', @$configs) );
1381 }
1382
84fb5b46
MKG
1383 return (1,
1384 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
b5747ff2
MKG
1385 $browser->host_port,
1386 $configs->[0]);
84fb5b46
MKG
1387}
1388
1389sub ExpandCSRFToken {
1390 my $ARGS = shift;
1391
1392 my $token = delete $ARGS->{CSRF_Token};
1393 return unless $token;
1394
1395 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1396 return unless $data;
1397 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1398
1399 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1400 return unless $user->ValidateAuthString( $data->{auth}, $token );
1401
1402 %{$ARGS} = %{$data->{args}};
b5747ff2 1403 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
84fb5b46
MKG
1404
1405 # We explicitly stored file attachments with the request, but not in
1406 # the session yet, as that would itself be an attack. Put them into
1407 # the session now, so they'll be visible.
1408 if ($data->{attach}) {
1409 my $filename = $data->{attach}{filename};
1410 my $mime = $data->{attach}{mime};
1411 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1412 = $mime;
1413 }
1414
1415 return 1;
1416}
1417
b5747ff2 1418sub StoreRequestToken {
84fb5b46
MKG
1419 my $ARGS = shift;
1420
84fb5b46
MKG
1421 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1422 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1423 my $data = {
1424 auth => $user->GenerateAuthString( $token ),
1425 path => $HTML::Mason::Commands::r->path_info,
1426 args => $ARGS,
1427 };
1428 if ($ARGS->{Attach}) {
1429 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1430 my $file_path = delete $ARGS->{'Attach'};
1431 $data->{attach} = {
1432 filename => Encode::decode_utf8("$file_path"),
1433 mime => $attachment,
1434 };
1435 }
1436
1437 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1438 $HTML::Mason::Commands::session{'i'}++;
b5747ff2
MKG
1439 return $token;
1440}
1441
1442sub MaybeShowInterstitialCSRFPage {
1443 my $ARGS = shift;
1444
1445 return unless RT->Config->Get('RestrictReferrer');
1446
1447 # Deal with the form token provided by the interstitial, which lets
1448 # browsers which never set referer headers still use RT, if
1449 # painfully. This blows values into ARGS
1450 return if ExpandCSRFToken($ARGS);
1451
1452 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1453 return if !$is_csrf;
1454
1455 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
84fb5b46 1456
b5747ff2 1457 my $token = StoreRequestToken($ARGS);
84fb5b46
MKG
1458 $HTML::Mason::Commands::m->comp(
1459 '/Elements/CSRF',
b5747ff2 1460 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
84fb5b46
MKG
1461 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1462 Token => $token,
1463 );
1464 # Calls abort, never gets here
1465}
1466
dab09ea8
MKG
1467our @POTENTIAL_PAGE_ACTIONS = (
1468 qr'/Ticket/Create.html' => "create a ticket", # loc
1469 qr'/Ticket/' => "update a ticket", # loc
1470 qr'/Admin/' => "modify RT's configuration", # loc
1471 qr'/Approval/' => "update an approval", # loc
1472 qr'/Articles/' => "update an article", # loc
1473 qr'/Dashboards/' => "modify a dashboard", # loc
1474 qr'/m/ticket/' => "update a ticket", # loc
1475 qr'Prefs' => "modify your preferences", # loc
1476 qr'/Search/' => "modify or access a search", # loc
1477 qr'/SelfService/Create' => "create a ticket", # loc
1478 qr'/SelfService/' => "update a ticket", # loc
1479);
1480
1481sub PotentialPageAction {
1482 my $page = shift;
1483 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1484 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1485 return HTML::Mason::Commands::loc($result)
1486 if $page =~ $pattern;
1487 }
1488 return "";
1489}
1490
84fb5b46
MKG
1491package HTML::Mason::Commands;
1492
1493use vars qw/$r $m %session/;
1494
1495sub Menu {
1496 return $HTML::Mason::Commands::m->notes('menu');
1497}
1498
1499sub PageMenu {
1500 return $HTML::Mason::Commands::m->notes('page-menu');
1501}
1502
1503sub PageWidgets {
1504 return $HTML::Mason::Commands::m->notes('page-widgets');
1505}
1506
1507
1508
1509=head2 loc ARRAY
1510
1511loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1512with whatever it's called with. If there is no $session{'CurrentUser'},
1513it creates a temporary user, so we have something to get a localisation handle
1514through
1515
1516=cut
1517
1518sub loc {
1519
1520 if ( $session{'CurrentUser'}
1521 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1522 {
1523 return ( $session{'CurrentUser'}->loc(@_) );
1524 } elsif (
1525 my $u = eval {
1526 RT::CurrentUser->new();
1527 }
1528 )
1529 {
1530 return ( $u->loc(@_) );
1531 } else {
1532
1533 # pathetic case -- SystemUser is gone.
1534 return $_[0];
1535 }
1536}
1537
1538
1539
1540=head2 loc_fuzzy STRING
1541
1542loc_fuzzy is for handling localizations of messages that may already
1543contain interpolated variables, typically returned from libraries
1544outside RT's control. It takes the message string and extracts the
1545variable array automatically by matching against the candidate entries
1546inside the lexicon file.
1547
1548=cut
1549
1550sub loc_fuzzy {
1551 my $msg = shift;
1552
1553 if ( $session{'CurrentUser'}
1554 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1555 {
1556 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1557 } else {
1558 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1559 return ( $u->loc_fuzzy($msg) );
1560 }
1561}
1562
1563
1564# Error - calls Error and aborts
1565sub Abort {
1566 my $why = shift;
1567 my %args = @_;
1568
1569 if ( $session{'ErrorDocument'}
1570 && $session{'ErrorDocumentType'} )
1571 {
1572 $r->content_type( $session{'ErrorDocumentType'} );
1573 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1574 $m->abort;
1575 } else {
1576 $m->comp( "/Elements/Error", Why => $why, %args );
1577 $m->abort;
1578 }
1579}
1580
1581sub MaybeRedirectForResults {
1582 my %args = (
1583 Path => $HTML::Mason::Commands::m->request_comp->path,
1584 Arguments => {},
1585 Anchor => undef,
1586 Actions => undef,
1587 Force => 0,
1588 @_
1589 );
1590 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1591 return unless $has_actions || $args{'Force'};
1592
1593 my %arguments = %{ $args{'Arguments'} };
1594
1595 if ( $has_actions ) {
1596 my $key = Digest::MD5::md5_hex( rand(1024) );
1597 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1598 $session{'i'}++;
1599 $arguments{'results'} = $key;
1600 }
1601
1602 $args{'Path'} =~ s!^/+!!;
1603 my $url = RT->Config->Get('WebURL') . $args{Path};
1604
1605 if ( keys %arguments ) {
1606 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1607 }
1608 if ( $args{'Anchor'} ) {
1609 $url .= "#". $args{'Anchor'};
1610 }
1611 return RT::Interface::Web::Redirect($url);
1612}
1613
1614=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1615
1616If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1617redirect to the approvals display page, preserving any arguments.
1618
1619C<Path>s matching C<Whitelist> are let through.
1620
1621This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1622
1623=cut
1624
1625sub MaybeRedirectToApproval {
1626 my %args = (
1627 Path => $HTML::Mason::Commands::m->request_comp->path,
1628 ARGSRef => {},
1629 Whitelist => undef,
1630 @_
1631 );
1632
1633 return unless $ENV{REQUEST_METHOD} eq 'GET';
1634
1635 my $id = $args{ARGSRef}->{id};
1636
1637 if ( $id
1638 and RT->Config->Get('ForceApprovalsView')
1639 and not $args{Path} =~ /$args{Whitelist}/)
1640 {
1641 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1642 $ticket->Load($id);
1643
1644 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1645 MaybeRedirectForResults(
1646 Path => "/Approvals/Display.html",
1647 Force => 1,
1648 Anchor => $args{ARGSRef}->{Anchor},
1649 Arguments => $args{ARGSRef},
1650 );
1651 }
1652 }
1653}
1654
1655=head2 CreateTicket ARGS
1656
1657Create a new ticket, using Mason's %ARGS. returns @results.
1658
1659=cut
1660
1661sub CreateTicket {
1662 my %ARGS = (@_);
1663
1664 my (@Actions);
1665
1666 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1667
1668 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1669 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1670 Abort('Queue not found');
1671 }
1672
1673 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1674 Abort('You have no permission to create tickets in that queue.');
1675 }
1676
1677 my $due;
1678 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1679 $due = RT::Date->new( $session{'CurrentUser'} );
1680 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1681 }
1682 my $starts;
1683 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1684 $starts = RT::Date->new( $session{'CurrentUser'} );
1685 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1686 }
1687
1688 my $sigless = RT::Interface::Web::StripContent(
1689 Content => $ARGS{Content},
1690 ContentType => $ARGS{ContentType},
1691 StripSignature => 1,
1692 CurrentUser => $session{'CurrentUser'},
1693 );
1694
1695 my $MIMEObj = MakeMIMEEntity(
1696 Subject => $ARGS{'Subject'},
1697 From => $ARGS{'From'},
1698 Cc => $ARGS{'Cc'},
1699 Body => $sigless,
1700 Type => $ARGS{'ContentType'},
1701 );
1702
1703 if ( $ARGS{'Attachments'} ) {
1704 my $rv = $MIMEObj->make_multipart;
1705 $RT::Logger->error("Couldn't make multipart message")
1706 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1707
1708 foreach ( values %{ $ARGS{'Attachments'} } ) {
1709 unless ($_) {
1710 $RT::Logger->error("Couldn't add empty attachemnt");
1711 next;
1712 }
1713 $MIMEObj->add_part($_);
1714 }
1715 }
1716
dab09ea8
MKG
1717 for my $argument (qw(Encrypt Sign)) {
1718 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
84fb5b46
MKG
1719 }
1720
1721 my %create_args = (
1722 Type => $ARGS{'Type'} || 'ticket',
1723 Queue => $ARGS{'Queue'},
1724 Owner => $ARGS{'Owner'},
1725
1726 # note: name change
1727 Requestor => $ARGS{'Requestors'},
1728 Cc => $ARGS{'Cc'},
1729 AdminCc => $ARGS{'AdminCc'},
1730 InitialPriority => $ARGS{'InitialPriority'},
1731 FinalPriority => $ARGS{'FinalPriority'},
1732 TimeLeft => $ARGS{'TimeLeft'},
1733 TimeEstimated => $ARGS{'TimeEstimated'},
1734 TimeWorked => $ARGS{'TimeWorked'},
1735 Subject => $ARGS{'Subject'},
1736 Status => $ARGS{'Status'},
1737 Due => $due ? $due->ISO : undef,
1738 Starts => $starts ? $starts->ISO : undef,
1739 MIMEObj => $MIMEObj
1740 );
1741
1742 my @txn_squelch;
1743 foreach my $type (qw(Requestor Cc AdminCc)) {
1744 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1745 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1746 }
1747 $create_args{TransSquelchMailTo} = \@txn_squelch
1748 if @txn_squelch;
1749
1750 if ( $ARGS{'AttachTickets'} ) {
1751 require RT::Action::SendEmail;
1752 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1753 ref $ARGS{'AttachTickets'}
1754 ? @{ $ARGS{'AttachTickets'} }
1755 : ( $ARGS{'AttachTickets'} ) );
1756 }
1757
1758 foreach my $arg ( keys %ARGS ) {
1759 next if $arg =~ /-(?:Magic|Category)$/;
1760
1761 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1762 $create_args{$arg} = $ARGS{$arg};
1763 }
1764
1765 # Object-RT::Ticket--CustomField-3-Values
1766 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1767 my $cfid = $1;
1768
1769 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1770 $cf->SetContextObject( $Queue );
1771 $cf->Load($cfid);
1772 unless ( $cf->id ) {
1773 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1774 next;
1775 }
1776
1777 if ( $arg =~ /-Upload$/ ) {
1778 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1779 next;
1780 }
1781
1782 my $type = $cf->Type;
1783
1784 my @values = ();
1785 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1786 @values = @{ $ARGS{$arg} };
1787 } elsif ( $type =~ /text/i ) {
1788 @values = ( $ARGS{$arg} );
1789 } else {
1790 no warnings 'uninitialized';
1791 @values = split /\r*\n/, $ARGS{$arg};
1792 }
1793 @values = grep length, map {
1794 s/\r+\n/\n/g;
1795 s/^\s+//;
1796 s/\s+$//;
1797 $_;
1798 }
1799 grep defined, @values;
1800
1801 $create_args{"CustomField-$cfid"} = \@values;
1802 }
1803 }
1804
1805 # turn new link lists into arrays, and pass in the proper arguments
1806 my %map = (
1807 'new-DependsOn' => 'DependsOn',
1808 'DependsOn-new' => 'DependedOnBy',
1809 'new-MemberOf' => 'Parents',
1810 'MemberOf-new' => 'Children',
1811 'new-RefersTo' => 'RefersTo',
1812 'RefersTo-new' => 'ReferredToBy',
1813 );
1814 foreach my $key ( keys %map ) {
1815 next unless $ARGS{$key};
1816 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1817
1818 }
1819
1820 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1821 unless ($id) {
1822 Abort($ErrMsg);
1823 }
1824
1825 push( @Actions, split( "\n", $ErrMsg ) );
1826 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1827 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1828 }
1829 return ( $Ticket, @Actions );
1830
1831}
1832
1833
1834
1835=head2 LoadTicket id
1836
1837Takes a ticket id as its only variable. if it's handed an array, it takes
1838the first value.
1839
1840Returns an RT::Ticket object as the current user.
1841
1842=cut
1843
1844sub LoadTicket {
1845 my $id = shift;
1846
1847 if ( ref($id) eq "ARRAY" ) {
1848 $id = $id->[0];
1849 }
1850
1851 unless ($id) {
1852 Abort("No ticket specified");
1853 }
1854
1855 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1856 $Ticket->Load($id);
1857 unless ( $Ticket->id ) {
1858 Abort("Could not load ticket $id");
1859 }
1860 return $Ticket;
1861}
1862
1863
1864
1865=head2 ProcessUpdateMessage
1866
1867Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1868
1869Don't write message if it only contains current user's signature and
1870SkipSignatureOnly argument is true. Function anyway adds attachments
1871and updates time worked field even if skips message. The default value
1872is true.
1873
1874=cut
1875
1876sub ProcessUpdateMessage {
1877
1878 my %args = (
1879 ARGSRef => undef,
1880 TicketObj => undef,
1881 SkipSignatureOnly => 1,
1882 @_
1883 );
1884
1885 if ( $args{ARGSRef}->{'UpdateAttachments'}
1886 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1887 {
1888 delete $args{ARGSRef}->{'UpdateAttachments'};
1889 }
1890
1891 # Strip the signature
1892 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1893 Content => $args{ARGSRef}->{UpdateContent},
1894 ContentType => $args{ARGSRef}->{UpdateContentType},
1895 StripSignature => $args{SkipSignatureOnly},
1896 CurrentUser => $args{'TicketObj'}->CurrentUser,
1897 );
1898
1899 # If, after stripping the signature, we have no message, move the
1900 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1901 # ProcessBasics can deal -- then bail out.
1902 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1903 and not length $args{ARGSRef}->{'UpdateContent'} )
1904 {
1905 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1906 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1907 }
1908 return;
1909 }
1910
1911 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1912 $args{ARGSRef}->{'UpdateSubject'} = undef;
1913 }
1914
1915 my $Message = MakeMIMEEntity(
1916 Subject => $args{ARGSRef}->{'UpdateSubject'},
1917 Body => $args{ARGSRef}->{'UpdateContent'},
1918 Type => $args{ARGSRef}->{'UpdateContentType'},
1919 );
1920
1921 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1922 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1923 ) );
1924 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1925 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1926 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1927 } else {
1928 $old_txn = $args{TicketObj}->Transactions->First();
1929 }
1930
1931 if ( my $msg = $old_txn->Message->First ) {
1932 RT::Interface::Email::SetInReplyTo(
1933 Message => $Message,
1934 InReplyTo => $msg
1935 );
1936 }
1937
1938 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1939 $Message->make_multipart;
1940 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1941 }
1942
1943 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1944 require RT::Action::SendEmail;
1945 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1946 ref $args{ARGSRef}->{'AttachTickets'}
1947 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1948 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1949 }
1950
1951 my %message_args = (
1952 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1953 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1954 MIMEObj => $Message,
1955 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
1956 );
1957
1958 _ProcessUpdateMessageRecipients(
1959 MessageArgs => \%message_args,
1960 %args,
1961 );
1962
1963 my @results;
1964 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1965 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1966 push( @results, $Description );
1967 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1968 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1969 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1970 push( @results, $Description );
1971 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1972 } else {
1973 push( @results,
1974 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1975 }
1976 return @results;
1977}
1978
1979sub _ProcessUpdateMessageRecipients {
1980 my %args = (
1981 ARGSRef => undef,
1982 TicketObj => undef,
1983 MessageArgs => undef,
1984 @_,
1985 );
1986
1987 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1988 my $cc = $args{ARGSRef}->{'UpdateCc'};
1989
1990 my $message_args = $args{MessageArgs};
1991
1992 $message_args->{CcMessageTo} = $cc;
1993 $message_args->{BccMessageTo} = $bcc;
1994
1995 my @txn_squelch;
1996 foreach my $type (qw(Cc AdminCc)) {
1997 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1998 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1999 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2000 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2001 }
2002 }
2003 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2004 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2005 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2006 }
2007
2008 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2009 $message_args->{SquelchMailTo} = \@txn_squelch
2010 if @txn_squelch;
2011
2012 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2013 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2014 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2015
2016 my $var = ucfirst($1) . 'MessageTo';
2017 my $value = $2;
2018 if ( $message_args->{$var} ) {
2019 $message_args->{$var} .= ", $value";
2020 } else {
2021 $message_args->{$var} = $value;
2022 }
2023 }
2024 }
2025}
2026
2027
2028
2029=head2 MakeMIMEEntity PARAMHASH
2030
2031Takes a paramhash Subject, Body and AttachmentFieldName.
2032
2033Also takes Form, Cc and Type as optional paramhash keys.
2034
2035 Returns a MIME::Entity.
2036
2037=cut
2038
2039sub MakeMIMEEntity {
2040
2041 #TODO document what else this takes.
2042 my %args = (
2043 Subject => undef,
2044 From => undef,
2045 Cc => undef,
2046 Body => undef,
2047 AttachmentFieldName => undef,
2048 Type => undef,
2049 @_,
2050 );
2051 my $Message = MIME::Entity->build(
2052 Type => 'multipart/mixed',
dab09ea8 2053 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
84fb5b46
MKG
2054 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2055 grep defined $args{$_}, qw(Subject From Cc)
2056 );
2057
2058 if ( defined $args{'Body'} && length $args{'Body'} ) {
2059
2060 # Make the update content have no 'weird' newlines in it
2061 $args{'Body'} =~ s/\r\n/\n/gs;
2062
2063 $Message->attach(
2064 Type => $args{'Type'} || 'text/plain',
2065 Charset => 'UTF-8',
2066 Data => $args{'Body'},
2067 );
2068 }
2069
2070 if ( $args{'AttachmentFieldName'} ) {
2071
2072 my $cgi_object = $m->cgi_object;
2073 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2074 if ( defined $filehandle && length $filehandle ) {
2075
2076 my ( @content, $buffer );
2077 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2078 push @content, $buffer;
2079 }
2080
2081 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2082
2083 my $filename = "$filehandle";
2084 $filename =~ s{^.*[\\/]}{};
2085
2086 $Message->attach(
2087 Type => $uploadinfo->{'Content-Type'},
2088 Filename => $filename,
2089 Data => \@content,
2090 );
2091 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2092 $Message->head->set( 'Subject' => $filename );
2093 }
2094
2095 # Attachment parts really shouldn't get a Message-ID
2096 $Message->head->delete('Message-ID');
2097 }
2098 }
2099
2100 $Message->make_singlepart;
2101
2102 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2103
2104 return ($Message);
2105
2106}
2107
2108
2109
2110=head2 ParseDateToISO
2111
2112Takes a date in an arbitrary format.
2113Returns an ISO date and time in GMT
2114
2115=cut
2116
2117sub ParseDateToISO {
2118 my $date = shift;
2119
2120 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2121 $date_obj->Set(
2122 Format => 'unknown',
2123 Value => $date
2124 );
2125 return ( $date_obj->ISO );
2126}
2127
2128
2129
2130sub ProcessACLChanges {
2131 my $ARGSref = shift;
2132
2133 #XXX: why don't we get ARGSref like in other Process* subs?
2134
2135 my @results;
2136
2137 foreach my $arg ( keys %$ARGSref ) {
2138 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2139
2140 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2141
2142 my @rights;
2143 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2144 @rights = @{ $ARGSref->{$arg} };
2145 } else {
2146 @rights = $ARGSref->{$arg};
2147 }
2148 @rights = grep $_, @rights;
2149 next unless @rights;
2150
2151 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2152 $principal->Load($principal_id);
2153
2154 my $obj;
2155 if ( $object_type eq 'RT::System' ) {
2156 $obj = $RT::System;
2157 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2158 $obj = $object_type->new( $session{'CurrentUser'} );
2159 $obj->Load($object_id);
2160 unless ( $obj->id ) {
2161 $RT::Logger->error("couldn't load $object_type #$object_id");
2162 next;
2163 }
2164 } else {
2165 $RT::Logger->error("object type '$object_type' is incorrect");
2166 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2167 next;
2168 }
2169
2170 foreach my $right (@rights) {
2171 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2172 push( @results, $msg );
2173 }
2174 }
2175
2176 return (@results);
2177}
2178
2179
2180=head2 ProcessACLs
2181
2182ProcessACLs expects values from a series of checkboxes that describe the full
2183set of rights a principal should have on an object.
2184
2185It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2186instead of with the prefixes Grant/RevokeRight. Each input should be an array
2187listing the rights the principal should have, and ProcessACLs will modify the
2188current rights to match. Additionally, the previously unused CheckACL input
2189listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2190rights are removed from a principal and as such no SetRights input is
2191submitted.
2192
2193=cut
2194
2195sub ProcessACLs {
2196 my $ARGSref = shift;
2197 my (%state, @results);
2198
2199 my $CheckACL = $ARGSref->{'CheckACL'};
2200 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2201
2202 # Check if we want to grant rights to a previously rights-less user
2203 for my $type (qw(user group)) {
2204 my $key = "AddPrincipalForRights-$type";
2205
2206 next unless $ARGSref->{$key};
2207
2208 my $principal;
2209 if ( $type eq 'user' ) {
2210 $principal = RT::User->new( $session{'CurrentUser'} );
2211 $principal->LoadByCol( Name => $ARGSref->{$key} );
2212 }
2213 else {
2214 $principal = RT::Group->new( $session{'CurrentUser'} );
2215 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2216 }
2217
2218 unless ($principal->PrincipalId) {
2219 push @results, loc("Couldn't load the specified principal");
2220 next;
2221 }
2222
2223 my $principal_id = $principal->PrincipalId;
2224
2225 # Turn our addprincipal rights spec into a real one
2226 for my $arg (keys %$ARGSref) {
2227 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2228
2229 my $tuple = "$principal_id-$1";
2230 my $key = "SetRights-$tuple";
2231
2232 # If we have it already, that's odd, but merge them
2233 if (grep { $_ eq $tuple } @check) {
2234 $ARGSref->{$key} = [
2235 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2236 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2237 ];
2238 } else {
2239 $ARGSref->{$key} = $ARGSref->{$arg};
2240 push @check, $tuple;
2241 }
2242 }
2243 }
2244
2245 # Build our rights state for each Principal-Object tuple
2246 foreach my $arg ( keys %$ARGSref ) {
2247 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2248
2249 my $tuple = $1;
2250 my $value = $ARGSref->{$arg};
2251 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2252 next unless @rights;
2253
2254 $state{$tuple} = { map { $_ => 1 } @rights };
2255 }
2256
2257 foreach my $tuple (List::MoreUtils::uniq @check) {
2258 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2259
2260 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2261
2262 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2263 $principal->Load($principal_id);
2264
2265 my $obj;
2266 if ( $object_type eq 'RT::System' ) {
2267 $obj = $RT::System;
2268 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2269 $obj = $object_type->new( $session{'CurrentUser'} );
2270 $obj->Load($object_id);
2271 unless ( $obj->id ) {
2272 $RT::Logger->error("couldn't load $object_type #$object_id");
2273 next;
2274 }
2275 } else {
2276 $RT::Logger->error("object type '$object_type' is incorrect");
2277 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2278 next;
2279 }
2280
2281 my $acls = RT::ACL->new($session{'CurrentUser'});
2282 $acls->LimitToObject( $obj );
2283 $acls->LimitToPrincipal( Id => $principal_id );
2284
2285 while ( my $ace = $acls->Next ) {
2286 my $right = $ace->RightName;
2287
2288 # Has right and should have right
2289 next if delete $state{$tuple}->{$right};
2290
2291 # Has right and shouldn't have right
2292 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2293 push @results, $msg;
2294 }
2295
2296 # For everything left, they don't have the right but they should
2297 for my $right (keys %{ $state{$tuple} || {} }) {
2298 delete $state{$tuple}->{$right};
2299 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2300 push @results, $msg;
2301 }
2302
2303 # Check our state for leftovers
2304 if ( keys %{ $state{$tuple} || {} } ) {
2305 my $missed = join '|', %{$state{$tuple} || {}};
2306 $RT::Logger->warn(
2307 "Uh-oh, it looks like we somehow missed a right in "
2308 ."ProcessACLs. Here's what was leftover: $missed"
2309 );
2310 }
2311 }
2312
2313 return (@results);
2314}
2315
2316
2317
2318
2319=head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2320
2321@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.
2322
2323Returns an array of success/failure messages
2324
2325=cut
2326
2327sub UpdateRecordObject {
2328 my %args = (
2329 ARGSRef => undef,
2330 AttributesRef => undef,
2331 Object => undef,
2332 AttributePrefix => undef,
2333 @_
2334 );
2335
2336 my $Object = $args{'Object'};
2337 my @results = $Object->Update(
2338 AttributesRef => $args{'AttributesRef'},
2339 ARGSRef => $args{'ARGSRef'},
2340 AttributePrefix => $args{'AttributePrefix'},
2341 );
2342
2343 return (@results);
2344}
2345
2346
2347
2348sub ProcessCustomFieldUpdates {
2349 my %args = (
2350 CustomFieldObj => undef,
2351 ARGSRef => undef,
2352 @_
2353 );
2354
2355 my $Object = $args{'CustomFieldObj'};
2356 my $ARGSRef = $args{'ARGSRef'};
2357
2358 my @attribs = qw(Name Type Description Queue SortOrder);
2359 my @results = UpdateRecordObject(
2360 AttributesRef => \@attribs,
2361 Object => $Object,
2362 ARGSRef => $ARGSRef
2363 );
2364
2365 my $prefix = "CustomField-" . $Object->Id;
2366 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2367 my ( $addval, $addmsg ) = $Object->AddValue(
2368 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2369 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2370 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2371 );
2372 push( @results, $addmsg );
2373 }
2374
2375 my @delete_values
2376 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2377 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2378 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2379
2380 foreach my $id (@delete_values) {
2381 next unless defined $id;
2382 my ( $err, $msg ) = $Object->DeleteValue($id);
2383 push( @results, $msg );
2384 }
2385
2386 my $vals = $Object->Values();
2387 while ( my $cfv = $vals->Next() ) {
2388 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2389 if ( $cfv->SortOrder != $so ) {
2390 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2391 push( @results, $msg );
2392 }
2393 }
2394 }
2395
2396 return (@results);
2397}
2398
2399
2400
2401=head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2402
2403Returns an array of results messages.
2404
2405=cut
2406
2407sub ProcessTicketBasics {
2408
2409 my %args = (
2410 TicketObj => undef,
2411 ARGSRef => undef,
2412 @_
2413 );
2414
2415 my $TicketObj = $args{'TicketObj'};
2416 my $ARGSRef = $args{'ARGSRef'};
2417
2418 my $OrigOwner = $TicketObj->Owner;
2419
2420 # Set basic fields
2421 my @attribs = qw(
2422 Subject
2423 FinalPriority
2424 Priority
2425 TimeEstimated
2426 TimeWorked
2427 TimeLeft
2428 Type
2429 Status
2430 Queue
2431 );
2432
2433 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2434 for my $field (qw(Queue Owner)) {
2435 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2436 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2437 my $temp = $class->new(RT->SystemUser);
2438 $temp->Load( $ARGSRef->{$field} );
2439 if ( $temp->id ) {
2440 $ARGSRef->{$field} = $temp->id;
2441 }
2442 }
2443 }
2444
2445 # Status isn't a field that can be set to a null value.
2446 # RT core complains if you try
2447 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2448
2449 my @results = UpdateRecordObject(
2450 AttributesRef => \@attribs,
2451 Object => $TicketObj,
2452 ARGSRef => $ARGSRef,
2453 );
2454
2455 # We special case owner changing, so we can use ForceOwnerChange
2456 if ( $ARGSRef->{'Owner'}
2457 && $ARGSRef->{'Owner'} !~ /\D/
2458 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2459 my ($ChownType);
2460 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2461 $ChownType = "Force";
2462 }
2463 else {
2464 $ChownType = "Set";
2465 }
2466
2467 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2468 push( @results, $msg );
2469 }
2470
2471 # }}}
2472
2473 return (@results);
2474}
2475
2476sub ProcessTicketReminders {
2477 my %args = (
2478 TicketObj => undef,
2479 ARGSRef => undef,
2480 @_
2481 );
2482
2483 my $Ticket = $args{'TicketObj'};
2484 my $args = $args{'ARGSRef'};
2485 my @results;
2486
2487 my $reminder_collection = $Ticket->Reminders->Collection;
2488
2489 if ( $args->{'update-reminders'} ) {
2490 while ( my $reminder = $reminder_collection->Next ) {
b5747ff2
MKG
2491 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2492 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
84fb5b46
MKG
2493 $Ticket->Reminders->Resolve($reminder);
2494 }
b5747ff2 2495 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
84fb5b46
MKG
2496 $Ticket->Reminders->Open($reminder);
2497 }
2498
2499 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2500 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2501 }
2502
2503 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2504 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2505 }
2506
2507 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2508 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2509 $DateObj->Set(
2510 Format => 'unknown',
2511 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2512 );
2513 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2514 $reminder->SetDue( $DateObj->ISO );
2515 }
2516 }
2517 }
2518 }
2519
2520 if ( $args->{'NewReminder-Subject'} ) {
2521 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2522 $due_obj->Set(
2523 Format => 'unknown',
2524 Value => $args->{'NewReminder-Due'}
2525 );
2526 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2527 Subject => $args->{'NewReminder-Subject'},
2528 Owner => $args->{'NewReminder-Owner'},
2529 Due => $due_obj->ISO
2530 );
2531 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2532 }
2533 return @results;
2534}
2535
2536sub ProcessTicketCustomFieldUpdates {
2537 my %args = @_;
2538 $args{'Object'} = delete $args{'TicketObj'};
2539 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2540
2541 # Build up a list of objects that we want to work with
2542 my %custom_fields_to_mod;
2543 foreach my $arg ( keys %$ARGSRef ) {
2544 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2545 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2546 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2547 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2548 }
2549 }
2550
2551 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2552}
2553
2554sub ProcessObjectCustomFieldUpdates {
2555 my %args = @_;
2556 my $ARGSRef = $args{'ARGSRef'};
2557 my @results;
2558
2559 # Build up a list of objects that we want to work with
2560 my %custom_fields_to_mod;
2561 foreach my $arg ( keys %$ARGSRef ) {
2562
2563 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2564 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2565
2566 # For each of those objects, find out what custom fields we want to work with.
2567 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2568 }
2569
2570 # For each of those objects
2571 foreach my $class ( keys %custom_fields_to_mod ) {
2572 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2573 my $Object = $args{'Object'};
2574 $Object = $class->new( $session{'CurrentUser'} )
2575 unless $Object && ref $Object eq $class;
2576
2577 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2578 unless ( $Object->id ) {
2579 $RT::Logger->warning("Couldn't load object $class #$id");
2580 next;
2581 }
2582
2583 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2584 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2585 $CustomFieldObj->SetContextObject($Object);
2586 $CustomFieldObj->LoadById($cf);
2587 unless ( $CustomFieldObj->id ) {
2588 $RT::Logger->warning("Couldn't load custom field #$cf");
2589 next;
2590 }
2591 push @results,
2592 _ProcessObjectCustomFieldUpdates(
2593 Prefix => "Object-$class-$id-CustomField-$cf-",
2594 Object => $Object,
2595 CustomField => $CustomFieldObj,
2596 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2597 );
2598 }
2599 }
2600 }
2601 return @results;
2602}
2603
2604sub _ProcessObjectCustomFieldUpdates {
2605 my %args = @_;
2606 my $cf = $args{'CustomField'};
2607 my $cf_type = $cf->Type || '';
2608
2609 # Remove blank Values since the magic field will take care of this. Sometimes
2610 # the browser gives you a blank value which causes CFs to be processed twice
2611 if ( defined $args{'ARGS'}->{'Values'}
2612 && !length $args{'ARGS'}->{'Values'}
2613 && $args{'ARGS'}->{'Values-Magic'} )
2614 {
2615 delete $args{'ARGS'}->{'Values'};
2616 }
2617
2618 my @results;
2619 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2620
2621 # skip category argument
2622 next if $arg eq 'Category';
2623
2624 # since http won't pass in a form element with a null value, we need
2625 # to fake it
2626 if ( $arg eq 'Values-Magic' ) {
2627
2628 # We don't care about the magic, if there's really a values element;
2629 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2630 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2631
2632 # "Empty" values does not mean anything for Image and Binary fields
2633 next if $cf_type =~ /^(?:Image|Binary)$/;
2634
2635 $arg = 'Values';
2636 $args{'ARGS'}->{'Values'} = undef;
2637 }
2638
2639 my @values = ();
2640 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2641 @values = @{ $args{'ARGS'}->{$arg} };
2642 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2643 @values = ( $args{'ARGS'}->{$arg} );
2644 } else {
2645 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2646 if defined $args{'ARGS'}->{$arg};
2647 }
2648 @values = grep length, map {
2649 s/\r+\n/\n/g;
2650 s/^\s+//;
2651 s/\s+$//;
2652 $_;
2653 }
2654 grep defined, @values;
2655
2656 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2657 foreach my $value (@values) {
2658 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2659 Field => $cf->id,
2660 Value => $value
2661 );
2662 push( @results, $msg );
2663 }
2664 } elsif ( $arg eq 'Upload' ) {
2665 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2666 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2667 push( @results, $msg );
2668 } elsif ( $arg eq 'DeleteValues' ) {
2669 foreach my $value (@values) {
2670 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2671 Field => $cf,
2672 Value => $value,
2673 );
2674 push( @results, $msg );
2675 }
2676 } elsif ( $arg eq 'DeleteValueIds' ) {
2677 foreach my $value (@values) {
2678 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2679 Field => $cf,
2680 ValueId => $value,
2681 );
2682 push( @results, $msg );
2683 }
2684 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2685 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2686
2687 my %values_hash;
2688 foreach my $value (@values) {
2689 if ( my $entry = $cf_values->HasEntry($value) ) {
2690 $values_hash{ $entry->id } = 1;
2691 next;
2692 }
2693
2694 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2695 Field => $cf,
2696 Value => $value
2697 );
2698 push( @results, $msg );
2699 $values_hash{$val} = 1 if $val;
2700 }
2701
2702 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2703 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2704
2705 $cf_values->RedoSearch;
2706 while ( my $cf_value = $cf_values->Next ) {
2707 next if $values_hash{ $cf_value->id };
2708
2709 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2710 Field => $cf,
2711 ValueId => $cf_value->id
2712 );
2713 push( @results, $msg );
2714 }
2715 } elsif ( $arg eq 'Values' ) {
2716 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2717
2718 # keep everything up to the point of difference, delete the rest
2719 my $delete_flag;
2720 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2721 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2722 shift @values;
2723 next;
2724 }
2725
2726 $delete_flag ||= 1;
2727 $old_cf->Delete;
2728 }
2729
2730 # now add/replace extra things, if any
2731 foreach my $value (@values) {
2732 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2733 Field => $cf,
2734 Value => $value
2735 );
2736 push( @results, $msg );
2737 }
2738 } else {
2739 push(
2740 @results,
2741 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2742 $cf->Name, ref $args{'Object'},
2743 $args{'Object'}->id
2744 )
2745 );
2746 }
2747 }
2748 return @results;
2749}
2750
2751
2752=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2753
2754Returns an array of results messages.
2755
2756=cut
2757
2758sub ProcessTicketWatchers {
2759 my %args = (
2760 TicketObj => undef,
2761 ARGSRef => undef,
2762 @_
2763 );
2764 my (@results);
2765
2766 my $Ticket = $args{'TicketObj'};
2767 my $ARGSRef = $args{'ARGSRef'};
2768
2769 # Munge watchers
2770
2771 foreach my $key ( keys %$ARGSRef ) {
2772
2773 # Delete deletable watchers
2774 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2775 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2776 PrincipalId => $2,
2777 Type => $1
2778 );
2779 push @results, $msg;
2780 }
2781
2782 # Delete watchers in the simple style demanded by the bulk manipulator
2783 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2784 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2785 Email => $ARGSRef->{$key},
2786 Type => $1
2787 );
2788 push @results, $msg;
2789 }
2790
2791 # Add new wathchers by email address
2792 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2793 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2794 {
2795
2796 #They're in this order because otherwise $1 gets clobbered :/
2797 my ( $code, $msg ) = $Ticket->AddWatcher(
2798 Type => $ARGSRef->{$key},
2799 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2800 );
2801 push @results, $msg;
2802 }
2803
2804 #Add requestors in the simple style demanded by the bulk manipulator
2805 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2806 my ( $code, $msg ) = $Ticket->AddWatcher(
2807 Type => $1,
2808 Email => $ARGSRef->{$key}
2809 );
2810 push @results, $msg;
2811 }
2812
2813 # Add new watchers by owner
2814 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2815 my $principal_id = $1;
2816 my $form = $ARGSRef->{$key};
2817 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2818 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2819
2820 my ( $code, $msg ) = $Ticket->AddWatcher(
2821 Type => $value,
2822 PrincipalId => $principal_id
2823 );
2824 push @results, $msg;
2825 }
2826 }
2827
2828 }
2829 return (@results);
2830}
2831
2832
2833
2834=head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2835
2836Returns an array of results messages.
2837
2838=cut
2839
2840sub ProcessTicketDates {
2841 my %args = (
2842 TicketObj => undef,
2843 ARGSRef => undef,
2844 @_
2845 );
2846
2847 my $Ticket = $args{'TicketObj'};
2848 my $ARGSRef = $args{'ARGSRef'};
2849
2850 my (@results);
2851
2852 # Set date fields
2853 my @date_fields = qw(
2854 Told
2855 Resolved
2856 Starts
2857 Started
2858 Due
2859 );
2860
2861 #Run through each field in this list. update the value if apropriate
2862 foreach my $field (@date_fields) {
2863 next unless exists $ARGSRef->{ $field . '_Date' };
2864 next if $ARGSRef->{ $field . '_Date' } eq '';
2865
2866 my ( $code, $msg );
2867
2868 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2869 $DateObj->Set(
2870 Format => 'unknown',
2871 Value => $ARGSRef->{ $field . '_Date' }
2872 );
2873
2874 my $obj = $field . "Obj";
2875 if ( ( defined $DateObj->Unix )
2876 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2877 {
2878 my $method = "Set$field";
2879 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2880 push @results, "$msg";
2881 }
2882 }
2883
2884 # }}}
2885 return (@results);
2886}
2887
2888
2889
2890=head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2891
2892Returns an array of results messages.
2893
2894=cut
2895
2896sub ProcessTicketLinks {
2897 my %args = (
2898 TicketObj => undef,
2899 ARGSRef => undef,
2900 @_
2901 );
2902
2903 my $Ticket = $args{'TicketObj'};
2904 my $ARGSRef = $args{'ARGSRef'};
2905
2906 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2907
2908 #Merge if we need to
2909 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2910 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2911 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2912 push @results, $msg;
2913 }
2914
2915 return (@results);
2916}
2917
2918
2919sub ProcessRecordLinks {
2920 my %args = (
2921 RecordObj => undef,
2922 ARGSRef => undef,
2923 @_
2924 );
2925
2926 my $Record = $args{'RecordObj'};
2927 my $ARGSRef = $args{'ARGSRef'};
2928
2929 my (@results);
2930
2931 # Delete links that are gone gone gone.
2932 foreach my $arg ( keys %$ARGSRef ) {
2933 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2934 my $base = $1;
2935 my $type = $2;
2936 my $target = $3;
2937
2938 my ( $val, $msg ) = $Record->DeleteLink(
2939 Base => $base,
2940 Type => $type,
2941 Target => $target
2942 );
2943
2944 push @results, $msg;
2945
2946 }
2947
2948 }
2949
2950 my @linktypes = qw( DependsOn MemberOf RefersTo );
2951
2952 foreach my $linktype (@linktypes) {
2953 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2954 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2955 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2956
2957 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2958 next unless $luri;
2959 $luri =~ s/\s+$//; # Strip trailing whitespace
2960 my ( $val, $msg ) = $Record->AddLink(
2961 Target => $luri,
2962 Type => $linktype
2963 );
2964 push @results, $msg;
2965 }
2966 }
2967 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2968 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2969 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2970
2971 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2972 next unless $luri;
2973 my ( $val, $msg ) = $Record->AddLink(
2974 Base => $luri,
2975 Type => $linktype
2976 );
2977
2978 push @results, $msg;
2979 }
2980 }
2981 }
2982
2983 return (@results);
2984}
2985
2986=head2 _UploadedFile ( $arg );
2987
2988Takes a CGI parameter name; if a file is uploaded under that name,
2989return a hash reference suitable for AddCustomFieldValue's use:
2990C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2991
2992Returns C<undef> if no files were uploaded in the C<$arg> field.
2993
2994=cut
2995
2996sub _UploadedFile {
2997 my $arg = shift;
2998 my $cgi_object = $m->cgi_object;
2999 my $fh = $cgi_object->upload($arg) or return undef;
3000 my $upload_info = $cgi_object->uploadInfo($fh);
3001
3002 my $filename = "$fh";
3003 $filename =~ s#^.*[\\/]##;
3004 binmode($fh);
3005
3006 return {
3007 Value => $filename,
3008 LargeContent => do { local $/; scalar <$fh> },
3009 ContentType => $upload_info->{'Content-Type'},
3010 };
3011}
3012
3013sub GetColumnMapEntry {
3014 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3015
3016 # deal with the simplest thing first
3017 if ( $args{'Map'}{ $args{'Name'} } ) {
3018 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3019 }
3020
3021 # complex things
3022 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3023 return undef unless $args{'Map'}->{$mainkey};
3024 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3025 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3026
3027 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3028 }
3029 return undef;
3030}
3031
3032sub ProcessColumnMapValue {
3033 my $value = shift;
3034 my %args = ( Arguments => [], Escape => 1, @_ );
3035
3036 if ( ref $value ) {
3037 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3038 my @tmp = $value->( @{ $args{'Arguments'} } );
3039 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3040 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3041 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3042 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3043 return $$value;
3044 }
3045 }
3046
3047 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3048 return $value;
3049}
3050
3051=head2 GetPrincipalsMap OBJECT, CATEGORIES
3052
3053Returns an array suitable for passing to /Admin/Elements/EditRights with the
3054principal collections mapped from the categories given.
3055
3056=cut
3057
3058sub GetPrincipalsMap {
3059 my $object = shift;
3060 my @map;
3061 for (@_) {
3062 if (/System/) {
3063 my $system = RT::Groups->new($session{'CurrentUser'});
3064 $system->LimitToSystemInternalGroups();
3065 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3066 push @map, [
3067 'System' => $system, # loc_left_pair
3068 'Type' => 1,
3069 ];
3070 }
3071 elsif (/Groups/) {
3072 my $groups = RT::Groups->new($session{'CurrentUser'});
3073 $groups->LimitToUserDefinedGroups();
3074 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3075
3076 # Only show groups who have rights granted on this object
3077 $groups->WithGroupRight(
3078 Right => '',
3079 Object => $object,
3080 IncludeSystemRights => 0,
3081 IncludeSubgroupMembers => 0,
3082 );
3083
3084 push @map, [
3085 'User Groups' => $groups, # loc_left_pair
3086 'Name' => 0
3087 ];
3088 }
3089 elsif (/Roles/) {
3090 my $roles = RT::Groups->new($session{'CurrentUser'});
3091
3092 if ($object->isa('RT::System')) {
3093 $roles->LimitToRolesForSystem();
3094 }
3095 elsif ($object->isa('RT::Queue')) {
3096 $roles->LimitToRolesForQueue($object->Id);
3097 }
3098 else {
3099 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3100 next;
3101 }
3102 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3103 push @map, [
3104 'Roles' => $roles, # loc_left_pair
3105 'Type' => 1
3106 ];
3107 }
3108 elsif (/Users/) {
3109 my $Users = RT->PrivilegedUsers->UserMembersObj();
3110 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3111
3112 # Only show users who have rights granted on this object
3113 my $group_members = $Users->WhoHaveGroupRight(
3114 Right => '',
3115 Object => $object,
3116 IncludeSystemRights => 0,
3117 IncludeSubgroupMembers => 0,
3118 );
3119
3120 # Limit to UserEquiv groups
3121 my $groups = $Users->NewAlias('Groups');
3122 $Users->Join(
3123 ALIAS1 => $groups,
3124 FIELD1 => 'id',
3125 ALIAS2 => $group_members,
3126 FIELD2 => 'GroupId'
3127 );
3128 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3129 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3130
3131
3132 my $display = sub {
3133 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3134 };
3135 push @map, [
3136 'Users' => $Users, # loc_left_pair
3137 $display => 0
3138 ];
3139 }
3140 }
3141 return @map;
3142}
3143
3144=head2 _load_container_object ( $type, $id );
3145
3146Instantiate container object for saving searches.
3147
3148=cut
3149
3150sub _load_container_object {
3151 my ( $obj_type, $obj_id ) = @_;
3152 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3153}
3154
3155=head2 _parse_saved_search ( $arg );
3156
3157Given a serialization string for saved search, and returns the
3158container object and the search id.
3159
3160=cut
3161
3162sub _parse_saved_search {
3163 my $spec = shift;
3164 return unless $spec;
3165 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3166 return;
3167 }
3168 my $obj_type = $1;
3169 my $obj_id = $2;
3170 my $search_id = $3;
3171
3172 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3173}
3174
3175=head2 ScrubHTML content
3176
3177Removes unsafe and undesired HTML from the passed content
3178
3179=cut
3180
3181my $SCRUBBER;
3182sub ScrubHTML {
3183 my $Content = shift;
3184 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3185
3186 $Content = '' if !defined($Content);
3187 return $SCRUBBER->scrub($Content);
3188}
3189
3190=head2 _NewScrubber
3191
3192Returns a new L<HTML::Scrubber> object.
3193
3194If you need to be more lax about what HTML tags and attributes are allowed,
3195create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3196following:
3197
3198 package HTML::Mason::Commands;
3199 # Let tables through
3200 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3201 1;
3202
3203=cut
3204
3205our @SCRUBBER_ALLOWED_TAGS = qw(
3206 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
b5747ff2 3207 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
84fb5b46
MKG
3208);
3209
3210our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3211 # Match http, ftp and relative urls
3212 # XXX: we also scrub format strings with this module then allow simple config options
3213 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3214 face => 1,
3215 size => 1,
3216 target => 1,
3217 style => qr{
3218 ^(?:\s*
3219 (?:(?:background-)?color: \s*
3220 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3221 \#[a-f0-9]{3,6} | # #fff or #ffffff
3222 [\w\-]+ # green, light-blue, etc.
3223 ) |
3224 text-align: \s* \w+ |
3225 font-size: \s* [\w.\-]+ |
3226 font-family: \s* [\w\s"',.\-]+ |
3227 font-weight: \s* [\w\-]+ |
3228
3229 # MS Office styles, which are probably fine. If we don't, then any
3230 # associated styles in the same attribute get stripped.
3231 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3232 )\s* ;? \s*)
3233 +$ # one or more of these allowed properties from here 'till sunset
3234 }ix,
b5747ff2
MKG
3235 dir => qr/^(rtl|ltr)$/i,
3236 lang => qr/^\w+(-\w+)?$/,
84fb5b46
MKG
3237);
3238
3239our %SCRUBBER_RULES = ();
3240
3241sub _NewScrubber {
3242 require HTML::Scrubber;
3243 my $scrubber = HTML::Scrubber->new();
3244 $scrubber->default(
3245 0,
3246 {
3247 %SCRUBBER_ALLOWED_ATTRIBUTES,
3248 '*' => 0, # require attributes be explicitly allowed
3249 },
3250 );
3251 $scrubber->deny(qw[*]);
3252 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3253 $scrubber->rules(%SCRUBBER_RULES);
3254
3255 # Scrubbing comments is vital since IE conditional comments can contain
3256 # arbitrary HTML and we'd pass it right on through.
3257 $scrubber->comment(0);
3258
3259 return $scrubber;
3260}
3261
3262=head2 JSON
3263
3264Redispatches to L<RT::Interface::Web/EncodeJSON>
3265
3266=cut
3267
3268sub JSON {
3269 RT::Interface::Web::EncodeJSON(@_);
3270}
3271
3272package RT::Interface::Web;
3273RT::Base->_ImportOverlays();
3274
32751;