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