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