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