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