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