Upgrade 4.0.17 clean.
[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
01e3b242 1758 foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
84fb5b46
MKG
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;
01e3b242
MKG
1991 $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
1992 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
84fb5b46
MKG
1993 }
1994
1995 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1996 require RT::Action::SendEmail;
1997 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1998 ref $args{ARGSRef}->{'AttachTickets'}
1999 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2000 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2001 }
2002
2003 my %message_args = (
2004 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2005 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2006 MIMEObj => $Message,
2007 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
2008 );
2009
2010 _ProcessUpdateMessageRecipients(
2011 MessageArgs => \%message_args,
2012 %args,
2013 );
2014
2015 my @results;
2016 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2017 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2018 push( @results, $Description );
2019 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2020 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2021 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2022 push( @results, $Description );
2023 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2024 } else {
2025 push( @results,
2026 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2027 }
2028 return @results;
2029}
2030
2031sub _ProcessUpdateMessageRecipients {
2032 my %args = (
2033 ARGSRef => undef,
2034 TicketObj => undef,
2035 MessageArgs => undef,
2036 @_,
2037 );
2038
2039 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2040 my $cc = $args{ARGSRef}->{'UpdateCc'};
2041
2042 my $message_args = $args{MessageArgs};
2043
2044 $message_args->{CcMessageTo} = $cc;
2045 $message_args->{BccMessageTo} = $bcc;
2046
2047 my @txn_squelch;
2048 foreach my $type (qw(Cc AdminCc)) {
2049 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2050 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2051 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2052 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2053 }
2054 }
2055 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2056 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2057 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2058 }
2059
2060 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2061 $message_args->{SquelchMailTo} = \@txn_squelch
2062 if @txn_squelch;
2063
2064 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2065 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2066 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2067
2068 my $var = ucfirst($1) . 'MessageTo';
2069 my $value = $2;
2070 if ( $message_args->{$var} ) {
2071 $message_args->{$var} .= ", $value";
2072 } else {
2073 $message_args->{$var} = $value;
2074 }
2075 }
2076 }
2077}
2078
5b0d0914
MKG
2079sub ProcessAttachments {
2080 my %args = (
2081 ARGSRef => {},
2082 @_
2083 );
2084
2085 my $ARGSRef = $args{ARGSRef} || {};
2086 # deal with deleting uploaded attachments
2087 foreach my $key ( keys %$ARGSRef ) {
2088 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2089 delete $session{'Attachments'}{$1};
2090 }
2091 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2092 }
2093
2094 # store the uploaded attachment in session
2095 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2096 { # attachment?
2097 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2098
2099 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2100 $session{'Attachments'} =
2101 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2102 }
2103
2104 # delete temporary storage entry to make WebUI clean
2105 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2106 {
2107 delete $session{'Attachments'};
2108 }
2109}
84fb5b46
MKG
2110
2111
2112=head2 MakeMIMEEntity PARAMHASH
2113
2114Takes a paramhash Subject, Body and AttachmentFieldName.
2115
2116Also takes Form, Cc and Type as optional paramhash keys.
2117
2118 Returns a MIME::Entity.
2119
2120=cut
2121
2122sub MakeMIMEEntity {
2123
2124 #TODO document what else this takes.
2125 my %args = (
2126 Subject => undef,
2127 From => undef,
2128 Cc => undef,
2129 Body => undef,
2130 AttachmentFieldName => undef,
2131 Type => undef,
403d7b0b 2132 Interface => 'API',
84fb5b46
MKG
2133 @_,
2134 );
2135 my $Message = MIME::Entity->build(
2136 Type => 'multipart/mixed',
dab09ea8 2137 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
403d7b0b 2138 "X-RT-Interface" => $args{Interface},
84fb5b46
MKG
2139 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2140 grep defined $args{$_}, qw(Subject From Cc)
2141 );
2142
2143 if ( defined $args{'Body'} && length $args{'Body'} ) {
2144
2145 # Make the update content have no 'weird' newlines in it
2146 $args{'Body'} =~ s/\r\n/\n/gs;
2147
2148 $Message->attach(
2149 Type => $args{'Type'} || 'text/plain',
2150 Charset => 'UTF-8',
2151 Data => $args{'Body'},
2152 );
2153 }
2154
2155 if ( $args{'AttachmentFieldName'} ) {
2156
2157 my $cgi_object = $m->cgi_object;
2158 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2159 if ( defined $filehandle && length $filehandle ) {
2160
2161 my ( @content, $buffer );
2162 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2163 push @content, $buffer;
2164 }
2165
2166 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2167
2168 my $filename = "$filehandle";
2169 $filename =~ s{^.*[\\/]}{};
2170
2171 $Message->attach(
2172 Type => $uploadinfo->{'Content-Type'},
2173 Filename => $filename,
2174 Data => \@content,
2175 );
2176 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2177 $Message->head->set( 'Subject' => $filename );
2178 }
2179
403d7b0b 2180 # Attachment parts really shouldn't get a Message-ID or "interface"
84fb5b46 2181 $Message->head->delete('Message-ID');
403d7b0b 2182 $Message->head->delete('X-RT-Interface');
84fb5b46
MKG
2183 }
2184 }
2185
2186 $Message->make_singlepart;
2187
2188 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2189
2190 return ($Message);
2191
2192}
2193
2194
2195
2196=head2 ParseDateToISO
2197
2198Takes a date in an arbitrary format.
2199Returns an ISO date and time in GMT
2200
2201=cut
2202
2203sub ParseDateToISO {
2204 my $date = shift;
2205
2206 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2207 $date_obj->Set(
2208 Format => 'unknown',
2209 Value => $date
2210 );
2211 return ( $date_obj->ISO );
2212}
2213
2214
2215
2216sub ProcessACLChanges {
2217 my $ARGSref = shift;
2218
2219 #XXX: why don't we get ARGSref like in other Process* subs?
2220
2221 my @results;
2222
2223 foreach my $arg ( keys %$ARGSref ) {
2224 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2225
2226 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2227
2228 my @rights;
2229 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2230 @rights = @{ $ARGSref->{$arg} };
2231 } else {
2232 @rights = $ARGSref->{$arg};
2233 }
2234 @rights = grep $_, @rights;
2235 next unless @rights;
2236
2237 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2238 $principal->Load($principal_id);
2239
2240 my $obj;
2241 if ( $object_type eq 'RT::System' ) {
2242 $obj = $RT::System;
2243 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2244 $obj = $object_type->new( $session{'CurrentUser'} );
2245 $obj->Load($object_id);
2246 unless ( $obj->id ) {
2247 $RT::Logger->error("couldn't load $object_type #$object_id");
2248 next;
2249 }
2250 } else {
2251 $RT::Logger->error("object type '$object_type' is incorrect");
2252 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2253 next;
2254 }
2255
2256 foreach my $right (@rights) {
2257 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2258 push( @results, $msg );
2259 }
2260 }
2261
2262 return (@results);
2263}
2264
2265
2266=head2 ProcessACLs
2267
2268ProcessACLs expects values from a series of checkboxes that describe the full
2269set of rights a principal should have on an object.
2270
2271It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2272instead of with the prefixes Grant/RevokeRight. Each input should be an array
2273listing the rights the principal should have, and ProcessACLs will modify the
2274current rights to match. Additionally, the previously unused CheckACL input
2275listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2276rights are removed from a principal and as such no SetRights input is
2277submitted.
2278
2279=cut
2280
2281sub ProcessACLs {
2282 my $ARGSref = shift;
2283 my (%state, @results);
2284
2285 my $CheckACL = $ARGSref->{'CheckACL'};
2286 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2287
2288 # Check if we want to grant rights to a previously rights-less user
2289 for my $type (qw(user group)) {
403d7b0b
MKG
2290 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2291 or next;
84fb5b46
MKG
2292
2293 unless ($principal->PrincipalId) {
2294 push @results, loc("Couldn't load the specified principal");
2295 next;
2296 }
2297
2298 my $principal_id = $principal->PrincipalId;
2299
2300 # Turn our addprincipal rights spec into a real one
2301 for my $arg (keys %$ARGSref) {
2302 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2303
2304 my $tuple = "$principal_id-$1";
2305 my $key = "SetRights-$tuple";
2306
2307 # If we have it already, that's odd, but merge them
2308 if (grep { $_ eq $tuple } @check) {
2309 $ARGSref->{$key} = [
2310 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2311 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2312 ];
2313 } else {
2314 $ARGSref->{$key} = $ARGSref->{$arg};
2315 push @check, $tuple;
2316 }
2317 }
2318 }
2319
2320 # Build our rights state for each Principal-Object tuple
2321 foreach my $arg ( keys %$ARGSref ) {
2322 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2323
2324 my $tuple = $1;
2325 my $value = $ARGSref->{$arg};
2326 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2327 next unless @rights;
2328
2329 $state{$tuple} = { map { $_ => 1 } @rights };
2330 }
2331
2332 foreach my $tuple (List::MoreUtils::uniq @check) {
2333 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2334
2335 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2336
2337 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2338 $principal->Load($principal_id);
2339
2340 my $obj;
2341 if ( $object_type eq 'RT::System' ) {
2342 $obj = $RT::System;
2343 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2344 $obj = $object_type->new( $session{'CurrentUser'} );
2345 $obj->Load($object_id);
2346 unless ( $obj->id ) {
2347 $RT::Logger->error("couldn't load $object_type #$object_id");
2348 next;
2349 }
2350 } else {
2351 $RT::Logger->error("object type '$object_type' is incorrect");
2352 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2353 next;
2354 }
2355
2356 my $acls = RT::ACL->new($session{'CurrentUser'});
2357 $acls->LimitToObject( $obj );
2358 $acls->LimitToPrincipal( Id => $principal_id );
2359
2360 while ( my $ace = $acls->Next ) {
2361 my $right = $ace->RightName;
2362
2363 # Has right and should have right
2364 next if delete $state{$tuple}->{$right};
2365
2366 # Has right and shouldn't have right
2367 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2368 push @results, $msg;
2369 }
2370
2371 # For everything left, they don't have the right but they should
2372 for my $right (keys %{ $state{$tuple} || {} }) {
2373 delete $state{$tuple}->{$right};
2374 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2375 push @results, $msg;
2376 }
2377
2378 # Check our state for leftovers
2379 if ( keys %{ $state{$tuple} || {} } ) {
2380 my $missed = join '|', %{$state{$tuple} || {}};
2381 $RT::Logger->warn(
2382 "Uh-oh, it looks like we somehow missed a right in "
2383 ."ProcessACLs. Here's what was leftover: $missed"
2384 );
2385 }
2386 }
2387
2388 return (@results);
2389}
2390
403d7b0b
MKG
2391=head2 _ParseACLNewPrincipal
2392
2393Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2394for the presence of rights being added on a principal of the specified type,
2395and returns undef if no new principal is being granted rights. Otherwise loads
2396up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2397may not be successfully loaded, and you should check C<->id> yourself.
2398
2399=cut
2400
2401sub _ParseACLNewPrincipal {
2402 my $ARGSref = shift;
2403 my $type = lc shift;
2404 my $key = "AddPrincipalForRights-$type";
2405
2406 return unless $ARGSref->{$key};
84fb5b46 2407
403d7b0b
MKG
2408 my $principal;
2409 if ( $type eq 'user' ) {
2410 $principal = RT::User->new( $session{'CurrentUser'} );
2411 $principal->LoadByCol( Name => $ARGSref->{$key} );
2412 }
2413 elsif ( $type eq 'group' ) {
2414 $principal = RT::Group->new( $session{'CurrentUser'} );
2415 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2416 }
2417 return $principal;
2418}
84fb5b46
MKG
2419
2420
2421=head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2422
2423@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.
2424
2425Returns an array of success/failure messages
2426
2427=cut
2428
2429sub UpdateRecordObject {
2430 my %args = (
2431 ARGSRef => undef,
2432 AttributesRef => undef,
2433 Object => undef,
2434 AttributePrefix => undef,
2435 @_
2436 );
2437
2438 my $Object = $args{'Object'};
2439 my @results = $Object->Update(
2440 AttributesRef => $args{'AttributesRef'},
2441 ARGSRef => $args{'ARGSRef'},
2442 AttributePrefix => $args{'AttributePrefix'},
2443 );
2444
2445 return (@results);
2446}
2447
2448
2449
2450sub ProcessCustomFieldUpdates {
2451 my %args = (
2452 CustomFieldObj => undef,
2453 ARGSRef => undef,
2454 @_
2455 );
2456
2457 my $Object = $args{'CustomFieldObj'};
2458 my $ARGSRef = $args{'ARGSRef'};
2459
2460 my @attribs = qw(Name Type Description Queue SortOrder);
2461 my @results = UpdateRecordObject(
2462 AttributesRef => \@attribs,
2463 Object => $Object,
2464 ARGSRef => $ARGSRef
2465 );
2466
2467 my $prefix = "CustomField-" . $Object->Id;
2468 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2469 my ( $addval, $addmsg ) = $Object->AddValue(
2470 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2471 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2472 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2473 );
2474 push( @results, $addmsg );
2475 }
2476
2477 my @delete_values
2478 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2479 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2480 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2481
2482 foreach my $id (@delete_values) {
2483 next unless defined $id;
2484 my ( $err, $msg ) = $Object->DeleteValue($id);
2485 push( @results, $msg );
2486 }
2487
2488 my $vals = $Object->Values();
2489 while ( my $cfv = $vals->Next() ) {
2490 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2491 if ( $cfv->SortOrder != $so ) {
2492 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2493 push( @results, $msg );
2494 }
2495 }
2496 }
2497
2498 return (@results);
2499}
2500
2501
2502
2503=head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2504
2505Returns an array of results messages.
2506
2507=cut
2508
2509sub ProcessTicketBasics {
2510
2511 my %args = (
2512 TicketObj => undef,
2513 ARGSRef => undef,
2514 @_
2515 );
2516
2517 my $TicketObj = $args{'TicketObj'};
2518 my $ARGSRef = $args{'ARGSRef'};
2519
2520 my $OrigOwner = $TicketObj->Owner;
2521
2522 # Set basic fields
2523 my @attribs = qw(
2524 Subject
2525 FinalPriority
2526 Priority
2527 TimeEstimated
2528 TimeWorked
2529 TimeLeft
2530 Type
2531 Status
2532 Queue
2533 );
2534
2535 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2536 for my $field (qw(Queue Owner)) {
2537 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2538 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2539 my $temp = $class->new(RT->SystemUser);
2540 $temp->Load( $ARGSRef->{$field} );
2541 if ( $temp->id ) {
2542 $ARGSRef->{$field} = $temp->id;
2543 }
2544 }
2545 }
2546
2547 # Status isn't a field that can be set to a null value.
2548 # RT core complains if you try
2549 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2550
2551 my @results = UpdateRecordObject(
2552 AttributesRef => \@attribs,
2553 Object => $TicketObj,
2554 ARGSRef => $ARGSRef,
2555 );
2556
2557 # We special case owner changing, so we can use ForceOwnerChange
2558 if ( $ARGSRef->{'Owner'}
2559 && $ARGSRef->{'Owner'} !~ /\D/
2560 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2561 my ($ChownType);
2562 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2563 $ChownType = "Force";
2564 }
2565 else {
2566 $ChownType = "Set";
2567 }
2568
2569 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2570 push( @results, $msg );
2571 }
2572
2573 # }}}
2574
2575 return (@results);
2576}
2577
2578sub ProcessTicketReminders {
2579 my %args = (
2580 TicketObj => undef,
2581 ARGSRef => undef,
2582 @_
2583 );
2584
2585 my $Ticket = $args{'TicketObj'};
2586 my $args = $args{'ARGSRef'};
2587 my @results;
2588
2589 my $reminder_collection = $Ticket->Reminders->Collection;
2590
2591 if ( $args->{'update-reminders'} ) {
2592 while ( my $reminder = $reminder_collection->Next ) {
b5747ff2
MKG
2593 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2594 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
01e3b242
MKG
2595 my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
2596 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2597
84fb5b46 2598 }
b5747ff2 2599 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
01e3b242
MKG
2600 my ($status, $msg) = $Ticket->Reminders->Open($reminder);
2601 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
84fb5b46
MKG
2602 }
2603
2604 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
01e3b242
MKG
2605 my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2606 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
84fb5b46
MKG
2607 }
2608
2609 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
01e3b242
MKG
2610 my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2611 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
84fb5b46
MKG
2612 }
2613
2614 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2615 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2616 $DateObj->Set(
2617 Format => 'unknown',
2618 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2619 );
2620 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
01e3b242
MKG
2621 my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
2622 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
84fb5b46
MKG
2623 }
2624 }
2625 }
2626 }
2627
2628 if ( $args->{'NewReminder-Subject'} ) {
2629 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2630 $due_obj->Set(
2631 Format => 'unknown',
2632 Value => $args->{'NewReminder-Due'}
2633 );
c36a7e1d 2634 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
84fb5b46
MKG
2635 Subject => $args->{'NewReminder-Subject'},
2636 Owner => $args->{'NewReminder-Owner'},
2637 Due => $due_obj->ISO
2638 );
c36a7e1d
MKG
2639 if ( $add_id ) {
2640 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2641 }
2642 else {
2643 push @results, $msg;
2644 }
84fb5b46
MKG
2645 }
2646 return @results;
2647}
2648
2649sub ProcessTicketCustomFieldUpdates {
2650 my %args = @_;
2651 $args{'Object'} = delete $args{'TicketObj'};
2652 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2653
2654 # Build up a list of objects that we want to work with
2655 my %custom_fields_to_mod;
2656 foreach my $arg ( keys %$ARGSRef ) {
2657 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2658 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2659 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2660 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2661 }
2662 }
2663
2664 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2665}
2666
2667sub ProcessObjectCustomFieldUpdates {
2668 my %args = @_;
2669 my $ARGSRef = $args{'ARGSRef'};
2670 my @results;
2671
2672 # Build up a list of objects that we want to work with
2673 my %custom_fields_to_mod;
2674 foreach my $arg ( keys %$ARGSRef ) {
2675
2676 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2677 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2678
2679 # For each of those objects, find out what custom fields we want to work with.
2680 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2681 }
2682
2683 # For each of those objects
2684 foreach my $class ( keys %custom_fields_to_mod ) {
2685 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2686 my $Object = $args{'Object'};
2687 $Object = $class->new( $session{'CurrentUser'} )
2688 unless $Object && ref $Object eq $class;
2689
2690 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2691 unless ( $Object->id ) {
2692 $RT::Logger->warning("Couldn't load object $class #$id");
2693 next;
2694 }
2695
2696 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2697 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2698 $CustomFieldObj->SetContextObject($Object);
2699 $CustomFieldObj->LoadById($cf);
2700 unless ( $CustomFieldObj->id ) {
2701 $RT::Logger->warning("Couldn't load custom field #$cf");
2702 next;
2703 }
2704 push @results,
2705 _ProcessObjectCustomFieldUpdates(
2706 Prefix => "Object-$class-$id-CustomField-$cf-",
2707 Object => $Object,
2708 CustomField => $CustomFieldObj,
2709 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2710 );
2711 }
2712 }
2713 }
2714 return @results;
2715}
2716
2717sub _ProcessObjectCustomFieldUpdates {
2718 my %args = @_;
2719 my $cf = $args{'CustomField'};
2720 my $cf_type = $cf->Type || '';
2721
2722 # Remove blank Values since the magic field will take care of this. Sometimes
2723 # the browser gives you a blank value which causes CFs to be processed twice
2724 if ( defined $args{'ARGS'}->{'Values'}
2725 && !length $args{'ARGS'}->{'Values'}
2726 && $args{'ARGS'}->{'Values-Magic'} )
2727 {
2728 delete $args{'ARGS'}->{'Values'};
2729 }
2730
2731 my @results;
2732 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2733
2734 # skip category argument
2735 next if $arg eq 'Category';
2736
2737 # since http won't pass in a form element with a null value, we need
2738 # to fake it
2739 if ( $arg eq 'Values-Magic' ) {
2740
2741 # We don't care about the magic, if there's really a values element;
2742 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2743 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2744
2745 # "Empty" values does not mean anything for Image and Binary fields
2746 next if $cf_type =~ /^(?:Image|Binary)$/;
2747
2748 $arg = 'Values';
2749 $args{'ARGS'}->{'Values'} = undef;
2750 }
2751
2752 my @values = ();
2753 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2754 @values = @{ $args{'ARGS'}->{$arg} };
2755 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2756 @values = ( $args{'ARGS'}->{$arg} );
2757 } else {
2758 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2759 if defined $args{'ARGS'}->{$arg};
2760 }
2761 @values = grep length, map {
2762 s/\r+\n/\n/g;
2763 s/^\s+//;
2764 s/\s+$//;
2765 $_;
2766 }
2767 grep defined, @values;
2768
2769 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2770 foreach my $value (@values) {
2771 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2772 Field => $cf->id,
2773 Value => $value
2774 );
2775 push( @results, $msg );
2776 }
2777 } elsif ( $arg eq 'Upload' ) {
2778 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2779 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2780 push( @results, $msg );
2781 } elsif ( $arg eq 'DeleteValues' ) {
2782 foreach my $value (@values) {
2783 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2784 Field => $cf,
2785 Value => $value,
2786 );
2787 push( @results, $msg );
2788 }
2789 } elsif ( $arg eq 'DeleteValueIds' ) {
2790 foreach my $value (@values) {
2791 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2792 Field => $cf,
2793 ValueId => $value,
2794 );
2795 push( @results, $msg );
2796 }
2797 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2798 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2799
2800 my %values_hash;
2801 foreach my $value (@values) {
2802 if ( my $entry = $cf_values->HasEntry($value) ) {
2803 $values_hash{ $entry->id } = 1;
2804 next;
2805 }
2806
2807 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2808 Field => $cf,
2809 Value => $value
2810 );
2811 push( @results, $msg );
2812 $values_hash{$val} = 1 if $val;
2813 }
2814
2815 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2816 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2817
2818 $cf_values->RedoSearch;
2819 while ( my $cf_value = $cf_values->Next ) {
2820 next if $values_hash{ $cf_value->id };
2821
2822 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2823 Field => $cf,
2824 ValueId => $cf_value->id
2825 );
2826 push( @results, $msg );
2827 }
2828 } elsif ( $arg eq 'Values' ) {
2829 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2830
2831 # keep everything up to the point of difference, delete the rest
2832 my $delete_flag;
2833 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2834 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2835 shift @values;
2836 next;
2837 }
2838
2839 $delete_flag ||= 1;
2840 $old_cf->Delete;
2841 }
2842
2843 # now add/replace extra things, if any
2844 foreach my $value (@values) {
2845 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2846 Field => $cf,
2847 Value => $value
2848 );
2849 push( @results, $msg );
2850 }
2851 } else {
2852 push(
2853 @results,
2854 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2855 $cf->Name, ref $args{'Object'},
2856 $args{'Object'}->id
2857 )
2858 );
2859 }
2860 }
2861 return @results;
2862}
2863
2864
2865=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2866
2867Returns an array of results messages.
2868
2869=cut
2870
2871sub ProcessTicketWatchers {
2872 my %args = (
2873 TicketObj => undef,
2874 ARGSRef => undef,
2875 @_
2876 );
2877 my (@results);
2878
2879 my $Ticket = $args{'TicketObj'};
2880 my $ARGSRef = $args{'ARGSRef'};
2881
2882 # Munge watchers
2883
2884 foreach my $key ( keys %$ARGSRef ) {
2885
2886 # Delete deletable watchers
2887 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2888 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2889 PrincipalId => $2,
2890 Type => $1
2891 );
2892 push @results, $msg;
2893 }
2894
2895 # Delete watchers in the simple style demanded by the bulk manipulator
2896 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2897 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2898 Email => $ARGSRef->{$key},
2899 Type => $1
2900 );
2901 push @results, $msg;
2902 }
2903
2904 # Add new wathchers by email address
2905 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2906 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2907 {
2908
2909 #They're in this order because otherwise $1 gets clobbered :/
2910 my ( $code, $msg ) = $Ticket->AddWatcher(
2911 Type => $ARGSRef->{$key},
2912 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2913 );
2914 push @results, $msg;
2915 }
2916
2917 #Add requestors in the simple style demanded by the bulk manipulator
2918 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2919 my ( $code, $msg ) = $Ticket->AddWatcher(
2920 Type => $1,
2921 Email => $ARGSRef->{$key}
2922 );
2923 push @results, $msg;
2924 }
2925
2926 # Add new watchers by owner
2927 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2928 my $principal_id = $1;
2929 my $form = $ARGSRef->{$key};
2930 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2931 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2932
2933 my ( $code, $msg ) = $Ticket->AddWatcher(
2934 Type => $value,
2935 PrincipalId => $principal_id
2936 );
2937 push @results, $msg;
2938 }
2939 }
2940
2941 }
2942 return (@results);
2943}
2944
2945
2946
2947=head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2948
2949Returns an array of results messages.
2950
2951=cut
2952
2953sub ProcessTicketDates {
2954 my %args = (
2955 TicketObj => undef,
2956 ARGSRef => undef,
2957 @_
2958 );
2959
2960 my $Ticket = $args{'TicketObj'};
2961 my $ARGSRef = $args{'ARGSRef'};
2962
2963 my (@results);
2964
2965 # Set date fields
2966 my @date_fields = qw(
2967 Told
2968 Resolved
2969 Starts
2970 Started
2971 Due
2972 );
2973
2974 #Run through each field in this list. update the value if apropriate
2975 foreach my $field (@date_fields) {
2976 next unless exists $ARGSRef->{ $field . '_Date' };
2977 next if $ARGSRef->{ $field . '_Date' } eq '';
2978
2979 my ( $code, $msg );
2980
2981 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2982 $DateObj->Set(
2983 Format => 'unknown',
2984 Value => $ARGSRef->{ $field . '_Date' }
2985 );
2986
2987 my $obj = $field . "Obj";
2988 if ( ( defined $DateObj->Unix )
2989 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2990 {
2991 my $method = "Set$field";
2992 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2993 push @results, "$msg";
2994 }
2995 }
2996
2997 # }}}
2998 return (@results);
2999}
3000
3001
3002
3003=head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3004
3005Returns an array of results messages.
3006
3007=cut
3008
3009sub ProcessTicketLinks {
3010 my %args = (
3011 TicketObj => undef,
3012 ARGSRef => undef,
3013 @_
3014 );
3015
3016 my $Ticket = $args{'TicketObj'};
3017 my $ARGSRef = $args{'ARGSRef'};
3018
3019 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3020
3021 #Merge if we need to
3022 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3023 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3024 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3025 push @results, $msg;
3026 }
3027
3028 return (@results);
3029}
3030
3031
3032sub ProcessRecordLinks {
3033 my %args = (
3034 RecordObj => undef,
3035 ARGSRef => undef,
3036 @_
3037 );
3038
3039 my $Record = $args{'RecordObj'};
3040 my $ARGSRef = $args{'ARGSRef'};
3041
3042 my (@results);
3043
3044 # Delete links that are gone gone gone.
3045 foreach my $arg ( keys %$ARGSRef ) {
3046 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3047 my $base = $1;
3048 my $type = $2;
3049 my $target = $3;
3050
3051 my ( $val, $msg ) = $Record->DeleteLink(
3052 Base => $base,
3053 Type => $type,
3054 Target => $target
3055 );
3056
3057 push @results, $msg;
3058
3059 }
3060
3061 }
3062
3063 my @linktypes = qw( DependsOn MemberOf RefersTo );
3064
3065 foreach my $linktype (@linktypes) {
3066 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3067 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3068 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3069
3070 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3071 next unless $luri;
3072 $luri =~ s/\s+$//; # Strip trailing whitespace
3073 my ( $val, $msg ) = $Record->AddLink(
3074 Target => $luri,
3075 Type => $linktype
3076 );
3077 push @results, $msg;
3078 }
3079 }
3080 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3081 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3082 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3083
3084 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3085 next unless $luri;
3086 my ( $val, $msg ) = $Record->AddLink(
3087 Base => $luri,
3088 Type => $linktype
3089 );
3090
3091 push @results, $msg;
3092 }
3093 }
3094 }
3095
3096 return (@results);
3097}
3098
c36a7e1d
MKG
3099=head2 ProcessTransactionSquelching
3100
3101Takes a hashref of the submitted form arguments, C<%ARGS>.
3102
3103Returns a hash of squelched addresses.
3104
3105=cut
3106
3107sub ProcessTransactionSquelching {
3108 my $args = shift;
3109 my %checked = map { $_ => 1 } grep { defined }
3110 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3111 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3112 () );
3113 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3114 return %squelched;
3115}
3116
84fb5b46
MKG
3117=head2 _UploadedFile ( $arg );
3118
3119Takes a CGI parameter name; if a file is uploaded under that name,
3120return a hash reference suitable for AddCustomFieldValue's use:
3121C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3122
3123Returns C<undef> if no files were uploaded in the C<$arg> field.
3124
3125=cut
3126
3127sub _UploadedFile {
3128 my $arg = shift;
3129 my $cgi_object = $m->cgi_object;
3130 my $fh = $cgi_object->upload($arg) or return undef;
3131 my $upload_info = $cgi_object->uploadInfo($fh);
3132
3133 my $filename = "$fh";
3134 $filename =~ s#^.*[\\/]##;
3135 binmode($fh);
3136
3137 return {
3138 Value => $filename,
3139 LargeContent => do { local $/; scalar <$fh> },
3140 ContentType => $upload_info->{'Content-Type'},
3141 };
3142}
3143
3144sub GetColumnMapEntry {
3145 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3146
3147 # deal with the simplest thing first
3148 if ( $args{'Map'}{ $args{'Name'} } ) {
3149 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3150 }
3151
3152 # complex things
01e3b242 3153 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.\{(.+)\}$/ ) {
84fb5b46
MKG
3154 return undef unless $args{'Map'}->{$mainkey};
3155 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3156 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3157
3158 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3159 }
3160 return undef;
3161}
3162
3163sub ProcessColumnMapValue {
3164 my $value = shift;
3165 my %args = ( Arguments => [], Escape => 1, @_ );
3166
3167 if ( ref $value ) {
3168 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3169 my @tmp = $value->( @{ $args{'Arguments'} } );
3170 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3171 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3172 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3173 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3174 return $$value;
3175 }
3176 }
3177
3178 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3179 return $value;
3180}
3181
3182=head2 GetPrincipalsMap OBJECT, CATEGORIES
3183
3184Returns an array suitable for passing to /Admin/Elements/EditRights with the
3185principal collections mapped from the categories given.
3186
3187=cut
3188
3189sub GetPrincipalsMap {
3190 my $object = shift;
3191 my @map;
3192 for (@_) {
3193 if (/System/) {
3194 my $system = RT::Groups->new($session{'CurrentUser'});
3195 $system->LimitToSystemInternalGroups();
3196 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3197 push @map, [
3198 'System' => $system, # loc_left_pair
3199 'Type' => 1,
3200 ];
3201 }
3202 elsif (/Groups/) {
3203 my $groups = RT::Groups->new($session{'CurrentUser'});
3204 $groups->LimitToUserDefinedGroups();
3205 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3206
3207 # Only show groups who have rights granted on this object
3208 $groups->WithGroupRight(
3209 Right => '',
3210 Object => $object,
3211 IncludeSystemRights => 0,
3212 IncludeSubgroupMembers => 0,
3213 );
3214
3215 push @map, [
3216 'User Groups' => $groups, # loc_left_pair
3217 'Name' => 0
3218 ];
3219 }
3220 elsif (/Roles/) {
3221 my $roles = RT::Groups->new($session{'CurrentUser'});
3222
3223 if ($object->isa('RT::System')) {
3224 $roles->LimitToRolesForSystem();
3225 }
3226 elsif ($object->isa('RT::Queue')) {
3227 $roles->LimitToRolesForQueue($object->Id);
3228 }
3229 else {
3230 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3231 next;
3232 }
3233 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3234 push @map, [
3235 'Roles' => $roles, # loc_left_pair
3236 'Type' => 1
3237 ];
3238 }
3239 elsif (/Users/) {
3240 my $Users = RT->PrivilegedUsers->UserMembersObj();
3241 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3242
3243 # Only show users who have rights granted on this object
3244 my $group_members = $Users->WhoHaveGroupRight(
3245 Right => '',
3246 Object => $object,
3247 IncludeSystemRights => 0,
3248 IncludeSubgroupMembers => 0,
3249 );
3250
3251 # Limit to UserEquiv groups
3252 my $groups = $Users->NewAlias('Groups');
3253 $Users->Join(
3254 ALIAS1 => $groups,
3255 FIELD1 => 'id',
3256 ALIAS2 => $group_members,
3257 FIELD2 => 'GroupId'
3258 );
3259 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3260 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3261
3262
3263 my $display = sub {
3264 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3265 };
3266 push @map, [
3267 'Users' => $Users, # loc_left_pair
3268 $display => 0
3269 ];
3270 }
3271 }
3272 return @map;
3273}
3274
3275=head2 _load_container_object ( $type, $id );
3276
3277Instantiate container object for saving searches.
3278
3279=cut
3280
3281sub _load_container_object {
3282 my ( $obj_type, $obj_id ) = @_;
3283 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3284}
3285
3286=head2 _parse_saved_search ( $arg );
3287
3288Given a serialization string for saved search, and returns the
3289container object and the search id.
3290
3291=cut
3292
3293sub _parse_saved_search {
3294 my $spec = shift;
3295 return unless $spec;
3296 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3297 return;
3298 }
3299 my $obj_type = $1;
3300 my $obj_id = $2;
3301 my $search_id = $3;
3302
3303 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3304}
3305
3306=head2 ScrubHTML content
3307
3308Removes unsafe and undesired HTML from the passed content
3309
3310=cut
3311
3312my $SCRUBBER;
3313sub ScrubHTML {
3314 my $Content = shift;
3315 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3316
3317 $Content = '' if !defined($Content);
3318 return $SCRUBBER->scrub($Content);
3319}
3320
3321=head2 _NewScrubber
3322
3323Returns a new L<HTML::Scrubber> object.
3324
3325If you need to be more lax about what HTML tags and attributes are allowed,
3326create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3327following:
3328
3329 package HTML::Mason::Commands;
3330 # Let tables through
3331 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3332 1;
3333
3334=cut
3335
3336our @SCRUBBER_ALLOWED_TAGS = qw(
3337 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
b5747ff2 3338 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
84fb5b46
MKG
3339);
3340
3341our %SCRUBBER_ALLOWED_ATTRIBUTES = (
c36a7e1d 3342 # Match http, https, ftp, mailto and relative urls
84fb5b46 3343 # XXX: we also scrub format strings with this module then allow simple config options
c36a7e1d 3344 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
84fb5b46
MKG
3345 face => 1,
3346 size => 1,
3347 target => 1,
3348 style => qr{
3349 ^(?:\s*
3350 (?:(?:background-)?color: \s*
3351 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3352 \#[a-f0-9]{3,6} | # #fff or #ffffff
3353 [\w\-]+ # green, light-blue, etc.
3354 ) |
3355 text-align: \s* \w+ |
3356 font-size: \s* [\w.\-]+ |
3357 font-family: \s* [\w\s"',.\-]+ |
3358 font-weight: \s* [\w\-]+ |
3359
3360 # MS Office styles, which are probably fine. If we don't, then any
3361 # associated styles in the same attribute get stripped.
3362 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3363 )\s* ;? \s*)
3364 +$ # one or more of these allowed properties from here 'till sunset
3365 }ix,
b5747ff2
MKG
3366 dir => qr/^(rtl|ltr)$/i,
3367 lang => qr/^\w+(-\w+)?$/,
84fb5b46
MKG
3368);
3369
3370our %SCRUBBER_RULES = ();
3371
3372sub _NewScrubber {
3373 require HTML::Scrubber;
3374 my $scrubber = HTML::Scrubber->new();
3375 $scrubber->default(
3376 0,
3377 {
3378 %SCRUBBER_ALLOWED_ATTRIBUTES,
3379 '*' => 0, # require attributes be explicitly allowed
3380 },
3381 );
3382 $scrubber->deny(qw[*]);
3383 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3384 $scrubber->rules(%SCRUBBER_RULES);
3385
3386 # Scrubbing comments is vital since IE conditional comments can contain
3387 # arbitrary HTML and we'd pass it right on through.
3388 $scrubber->comment(0);
3389
3390 return $scrubber;
3391}
3392
3393=head2 JSON
3394
3395Redispatches to L<RT::Interface::Web/EncodeJSON>
3396
3397=cut
3398
3399sub JSON {
3400 RT::Interface::Web::EncodeJSON(@_);
3401}
3402
3403package RT::Interface::Web;
3404RT::Base->_ImportOverlays();
3405
34061;