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