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