Master -> 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             if (   $reminder->Status ne 'resolved' && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2383                 $Ticket->Reminders->Resolve($reminder);
2384             }
2385             elsif ( $reminder->Status eq 'resolved' && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2386                 $Ticket->Reminders->Open($reminder);
2387             }
2388
2389             if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2390                 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2391             }
2392
2393             if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2394                 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2395             }
2396
2397             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2398                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2399                 $DateObj->Set(
2400                     Format => 'unknown',
2401                     Value  => $args->{ 'Reminder-Due-' . $reminder->id }
2402                 );
2403                 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2404                     $reminder->SetDue( $DateObj->ISO );
2405                 }
2406             }
2407         }
2408     }
2409
2410     if ( $args->{'NewReminder-Subject'} ) {
2411         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2412         $due_obj->Set(
2413           Format => 'unknown',
2414           Value => $args->{'NewReminder-Due'}
2415         );
2416         my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2417             Subject => $args->{'NewReminder-Subject'},
2418             Owner   => $args->{'NewReminder-Owner'},
2419             Due     => $due_obj->ISO
2420         );
2421         push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2422     }
2423     return @results;
2424 }
2425
2426 sub ProcessTicketCustomFieldUpdates {
2427     my %args = @_;
2428     $args{'Object'} = delete $args{'TicketObj'};
2429     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2430
2431     # Build up a list of objects that we want to work with
2432     my %custom_fields_to_mod;
2433     foreach my $arg ( keys %$ARGSRef ) {
2434         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2435             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2436         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2437             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2438         }
2439     }
2440
2441     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2442 }
2443
2444 sub ProcessObjectCustomFieldUpdates {
2445     my %args    = @_;
2446     my $ARGSRef = $args{'ARGSRef'};
2447     my @results;
2448
2449     # Build up a list of objects that we want to work with
2450     my %custom_fields_to_mod;
2451     foreach my $arg ( keys %$ARGSRef ) {
2452
2453         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2454         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2455
2456         # For each of those objects, find out what custom fields we want to work with.
2457         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2458     }
2459
2460     # For each of those objects
2461     foreach my $class ( keys %custom_fields_to_mod ) {
2462         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2463             my $Object = $args{'Object'};
2464             $Object = $class->new( $session{'CurrentUser'} )
2465                 unless $Object && ref $Object eq $class;
2466
2467             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2468             unless ( $Object->id ) {
2469                 $RT::Logger->warning("Couldn't load object $class #$id");
2470                 next;
2471             }
2472
2473             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2474                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2475                 $CustomFieldObj->SetContextObject($Object);
2476                 $CustomFieldObj->LoadById($cf);
2477                 unless ( $CustomFieldObj->id ) {
2478                     $RT::Logger->warning("Couldn't load custom field #$cf");
2479                     next;
2480                 }
2481                 push @results,
2482                     _ProcessObjectCustomFieldUpdates(
2483                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2484                     Object      => $Object,
2485                     CustomField => $CustomFieldObj,
2486                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2487                     );
2488             }
2489         }
2490     }
2491     return @results;
2492 }
2493
2494 sub _ProcessObjectCustomFieldUpdates {
2495     my %args    = @_;
2496     my $cf      = $args{'CustomField'};
2497     my $cf_type = $cf->Type || '';
2498
2499     # Remove blank Values since the magic field will take care of this. Sometimes
2500     # the browser gives you a blank value which causes CFs to be processed twice
2501     if (   defined $args{'ARGS'}->{'Values'}
2502         && !length $args{'ARGS'}->{'Values'}
2503         && $args{'ARGS'}->{'Values-Magic'} )
2504     {
2505         delete $args{'ARGS'}->{'Values'};
2506     }
2507
2508     my @results;
2509     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2510
2511         # skip category argument
2512         next if $arg eq 'Category';
2513
2514         # since http won't pass in a form element with a null value, we need
2515         # to fake it
2516         if ( $arg eq 'Values-Magic' ) {
2517
2518             # We don't care about the magic, if there's really a values element;
2519             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2520             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2521
2522             # "Empty" values does not mean anything for Image and Binary fields
2523             next if $cf_type =~ /^(?:Image|Binary)$/;
2524
2525             $arg = 'Values';
2526             $args{'ARGS'}->{'Values'} = undef;
2527         }
2528
2529         my @values = ();
2530         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2531             @values = @{ $args{'ARGS'}->{$arg} };
2532         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2533             @values = ( $args{'ARGS'}->{$arg} );
2534         } else {
2535             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2536                 if defined $args{'ARGS'}->{$arg};
2537         }
2538         @values = grep length, map {
2539             s/\r+\n/\n/g;
2540             s/^\s+//;
2541             s/\s+$//;
2542             $_;
2543             }
2544             grep defined, @values;
2545
2546         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2547             foreach my $value (@values) {
2548                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2549                     Field => $cf->id,
2550                     Value => $value
2551                 );
2552                 push( @results, $msg );
2553             }
2554         } elsif ( $arg eq 'Upload' ) {
2555             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2556             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2557             push( @results, $msg );
2558         } elsif ( $arg eq 'DeleteValues' ) {
2559             foreach my $value (@values) {
2560                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2561                     Field => $cf,
2562                     Value => $value,
2563                 );
2564                 push( @results, $msg );
2565             }
2566         } elsif ( $arg eq 'DeleteValueIds' ) {
2567             foreach my $value (@values) {
2568                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2569                     Field   => $cf,
2570                     ValueId => $value,
2571                 );
2572                 push( @results, $msg );
2573             }
2574         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2575             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2576
2577             my %values_hash;
2578             foreach my $value (@values) {
2579                 if ( my $entry = $cf_values->HasEntry($value) ) {
2580                     $values_hash{ $entry->id } = 1;
2581                     next;
2582                 }
2583
2584                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2585                     Field => $cf,
2586                     Value => $value
2587                 );
2588                 push( @results, $msg );
2589                 $values_hash{$val} = 1 if $val;
2590             }
2591
2592             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2593             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2594
2595             $cf_values->RedoSearch;
2596             while ( my $cf_value = $cf_values->Next ) {
2597                 next if $values_hash{ $cf_value->id };
2598
2599                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2600                     Field   => $cf,
2601                     ValueId => $cf_value->id
2602                 );
2603                 push( @results, $msg );
2604             }
2605         } elsif ( $arg eq 'Values' ) {
2606             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2607
2608             # keep everything up to the point of difference, delete the rest
2609             my $delete_flag;
2610             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2611                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2612                     shift @values;
2613                     next;
2614                 }
2615
2616                 $delete_flag ||= 1;
2617                 $old_cf->Delete;
2618             }
2619
2620             # now add/replace extra things, if any
2621             foreach my $value (@values) {
2622                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2623                     Field => $cf,
2624                     Value => $value
2625                 );
2626                 push( @results, $msg );
2627             }
2628         } else {
2629             push(
2630                 @results,
2631                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2632                     $cf->Name, ref $args{'Object'},
2633                     $args{'Object'}->id
2634                 )
2635             );
2636         }
2637     }
2638     return @results;
2639 }
2640
2641
2642 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2643
2644 Returns an array of results messages.
2645
2646 =cut
2647
2648 sub ProcessTicketWatchers {
2649     my %args = (
2650         TicketObj => undef,
2651         ARGSRef   => undef,
2652         @_
2653     );
2654     my (@results);
2655
2656     my $Ticket  = $args{'TicketObj'};
2657     my $ARGSRef = $args{'ARGSRef'};
2658
2659     # Munge watchers
2660
2661     foreach my $key ( keys %$ARGSRef ) {
2662
2663         # Delete deletable watchers
2664         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2665             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2666                 PrincipalId => $2,
2667                 Type        => $1
2668             );
2669             push @results, $msg;
2670         }
2671
2672         # Delete watchers in the simple style demanded by the bulk manipulator
2673         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2674             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2675                 Email => $ARGSRef->{$key},
2676                 Type  => $1
2677             );
2678             push @results, $msg;
2679         }
2680
2681         # Add new wathchers by email address
2682         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2683             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2684         {
2685
2686             #They're in this order because otherwise $1 gets clobbered :/
2687             my ( $code, $msg ) = $Ticket->AddWatcher(
2688                 Type  => $ARGSRef->{$key},
2689                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2690             );
2691             push @results, $msg;
2692         }
2693
2694         #Add requestors in the simple style demanded by the bulk manipulator
2695         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2696             my ( $code, $msg ) = $Ticket->AddWatcher(
2697                 Type  => $1,
2698                 Email => $ARGSRef->{$key}
2699             );
2700             push @results, $msg;
2701         }
2702
2703         # Add new  watchers by owner
2704         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2705             my $principal_id = $1;
2706             my $form         = $ARGSRef->{$key};
2707             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2708                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2709
2710                 my ( $code, $msg ) = $Ticket->AddWatcher(
2711                     Type        => $value,
2712                     PrincipalId => $principal_id
2713                 );
2714                 push @results, $msg;
2715             }
2716         }
2717
2718     }
2719     return (@results);
2720 }
2721
2722
2723
2724 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2725
2726 Returns an array of results messages.
2727
2728 =cut
2729
2730 sub ProcessTicketDates {
2731     my %args = (
2732         TicketObj => undef,
2733         ARGSRef   => undef,
2734         @_
2735     );
2736
2737     my $Ticket  = $args{'TicketObj'};
2738     my $ARGSRef = $args{'ARGSRef'};
2739
2740     my (@results);
2741
2742     # Set date fields
2743     my @date_fields = qw(
2744         Told
2745         Resolved
2746         Starts
2747         Started
2748         Due
2749     );
2750
2751     #Run through each field in this list. update the value if apropriate
2752     foreach my $field (@date_fields) {
2753         next unless exists $ARGSRef->{ $field . '_Date' };
2754         next if $ARGSRef->{ $field . '_Date' } eq '';
2755
2756         my ( $code, $msg );
2757
2758         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2759         $DateObj->Set(
2760             Format => 'unknown',
2761             Value  => $ARGSRef->{ $field . '_Date' }
2762         );
2763
2764         my $obj = $field . "Obj";
2765         if (    ( defined $DateObj->Unix )
2766             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2767         {
2768             my $method = "Set$field";
2769             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2770             push @results, "$msg";
2771         }
2772     }
2773
2774     # }}}
2775     return (@results);
2776 }
2777
2778
2779
2780 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2781
2782 Returns an array of results messages.
2783
2784 =cut
2785
2786 sub ProcessTicketLinks {
2787     my %args = (
2788         TicketObj => undef,
2789         ARGSRef   => undef,
2790         @_
2791     );
2792
2793     my $Ticket  = $args{'TicketObj'};
2794     my $ARGSRef = $args{'ARGSRef'};
2795
2796     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2797
2798     #Merge if we need to
2799     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2800         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2801         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2802         push @results, $msg;
2803     }
2804
2805     return (@results);
2806 }
2807
2808
2809 sub ProcessRecordLinks {
2810     my %args = (
2811         RecordObj => undef,
2812         ARGSRef   => undef,
2813         @_
2814     );
2815
2816     my $Record  = $args{'RecordObj'};
2817     my $ARGSRef = $args{'ARGSRef'};
2818
2819     my (@results);
2820
2821     # Delete links that are gone gone gone.
2822     foreach my $arg ( keys %$ARGSRef ) {
2823         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2824             my $base   = $1;
2825             my $type   = $2;
2826             my $target = $3;
2827
2828             my ( $val, $msg ) = $Record->DeleteLink(
2829                 Base   => $base,
2830                 Type   => $type,
2831                 Target => $target
2832             );
2833
2834             push @results, $msg;
2835
2836         }
2837
2838     }
2839
2840     my @linktypes = qw( DependsOn MemberOf RefersTo );
2841
2842     foreach my $linktype (@linktypes) {
2843         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2844             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2845                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2846
2847             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2848                 next unless $luri;
2849                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2850                 my ( $val, $msg ) = $Record->AddLink(
2851                     Target => $luri,
2852                     Type   => $linktype
2853                 );
2854                 push @results, $msg;
2855             }
2856         }
2857         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2858             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2859                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2860
2861             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2862                 next unless $luri;
2863                 my ( $val, $msg ) = $Record->AddLink(
2864                     Base => $luri,
2865                     Type => $linktype
2866                 );
2867
2868                 push @results, $msg;
2869             }
2870         }
2871     }
2872
2873     return (@results);
2874 }
2875
2876 =head2 _UploadedFile ( $arg );
2877
2878 Takes a CGI parameter name; if a file is uploaded under that name,
2879 return a hash reference suitable for AddCustomFieldValue's use:
2880 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2881
2882 Returns C<undef> if no files were uploaded in the C<$arg> field.
2883
2884 =cut
2885
2886 sub _UploadedFile {
2887     my $arg         = shift;
2888     my $cgi_object  = $m->cgi_object;
2889     my $fh          = $cgi_object->upload($arg) or return undef;
2890     my $upload_info = $cgi_object->uploadInfo($fh);
2891
2892     my $filename = "$fh";
2893     $filename =~ s#^.*[\\/]##;
2894     binmode($fh);
2895
2896     return {
2897         Value        => $filename,
2898         LargeContent => do { local $/; scalar <$fh> },
2899         ContentType  => $upload_info->{'Content-Type'},
2900     };
2901 }
2902
2903 sub GetColumnMapEntry {
2904     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2905
2906     # deal with the simplest thing first
2907     if ( $args{'Map'}{ $args{'Name'} } ) {
2908         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2909     }
2910
2911     # complex things
2912     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2913         return undef unless $args{'Map'}->{$mainkey};
2914         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2915             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2916
2917         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2918     }
2919     return undef;
2920 }
2921
2922 sub ProcessColumnMapValue {
2923     my $value = shift;
2924     my %args = ( Arguments => [], Escape => 1, @_ );
2925
2926     if ( ref $value ) {
2927         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2928             my @tmp = $value->( @{ $args{'Arguments'} } );
2929             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2930         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2931             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2932         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2933             return $$value;
2934         }
2935     }
2936
2937     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2938     return $value;
2939 }
2940
2941 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2942
2943 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2944 principal collections mapped from the categories given.
2945
2946 =cut
2947
2948 sub GetPrincipalsMap {
2949     my $object = shift;
2950     my @map;
2951     for (@_) {
2952         if (/System/) {
2953             my $system = RT::Groups->new($session{'CurrentUser'});
2954             $system->LimitToSystemInternalGroups();
2955             $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2956             push @map, [
2957                 'System' => $system,    # loc_left_pair
2958                 'Type'   => 1,
2959             ];
2960         }
2961         elsif (/Groups/) {
2962             my $groups = RT::Groups->new($session{'CurrentUser'});
2963             $groups->LimitToUserDefinedGroups();
2964             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2965
2966             # Only show groups who have rights granted on this object
2967             $groups->WithGroupRight(
2968                 Right   => '',
2969                 Object  => $object,
2970                 IncludeSystemRights => 0,
2971                 IncludeSubgroupMembers => 0,
2972             );
2973
2974             push @map, [
2975                 'User Groups' => $groups,   # loc_left_pair
2976                 'Name'        => 0
2977             ];
2978         }
2979         elsif (/Roles/) {
2980             my $roles = RT::Groups->new($session{'CurrentUser'});
2981
2982             if ($object->isa('RT::System')) {
2983                 $roles->LimitToRolesForSystem();
2984             }
2985             elsif ($object->isa('RT::Queue')) {
2986                 $roles->LimitToRolesForQueue($object->Id);
2987             }
2988             else {
2989                 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
2990                 next;
2991             }
2992             $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2993             push @map, [
2994                 'Roles' => $roles,  # loc_left_pair
2995                 'Type'  => 1
2996             ];
2997         }
2998         elsif (/Users/) {
2999             my $Users = RT->PrivilegedUsers->UserMembersObj();
3000             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3001
3002             # Only show users who have rights granted on this object
3003             my $group_members = $Users->WhoHaveGroupRight(
3004                 Right   => '',
3005                 Object  => $object,
3006                 IncludeSystemRights => 0,
3007                 IncludeSubgroupMembers => 0,
3008             );
3009
3010             # Limit to UserEquiv groups
3011             my $groups = $Users->NewAlias('Groups');
3012             $Users->Join(
3013                 ALIAS1 => $groups,
3014                 FIELD1 => 'id',
3015                 ALIAS2 => $group_members,
3016                 FIELD2 => 'GroupId'
3017             );
3018             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3019             $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3020
3021
3022             my $display = sub {
3023                 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3024             };
3025             push @map, [
3026                 'Users' => $Users,  # loc_left_pair
3027                 $display => 0
3028             ];
3029         }
3030     }
3031     return @map;
3032 }
3033
3034 =head2 _load_container_object ( $type, $id );
3035
3036 Instantiate container object for saving searches.
3037
3038 =cut
3039
3040 sub _load_container_object {
3041     my ( $obj_type, $obj_id ) = @_;
3042     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3043 }
3044
3045 =head2 _parse_saved_search ( $arg );
3046
3047 Given a serialization string for saved search, and returns the
3048 container object and the search id.
3049
3050 =cut
3051
3052 sub _parse_saved_search {
3053     my $spec = shift;
3054     return unless $spec;
3055     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3056         return;
3057     }
3058     my $obj_type  = $1;
3059     my $obj_id    = $2;
3060     my $search_id = $3;
3061
3062     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3063 }
3064
3065 =head2 ScrubHTML content
3066
3067 Removes unsafe and undesired HTML from the passed content
3068
3069 =cut
3070
3071 my $SCRUBBER;
3072 sub ScrubHTML {
3073     my $Content = shift;
3074     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3075
3076     $Content = '' if !defined($Content);
3077     return $SCRUBBER->scrub($Content);
3078 }
3079
3080 =head2 _NewScrubber
3081
3082 Returns a new L<HTML::Scrubber> object.
3083
3084 If you need to be more lax about what HTML tags and attributes are allowed,
3085 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3086 following:
3087
3088     package HTML::Mason::Commands;
3089     # Let tables through
3090     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3091     1;
3092
3093 =cut
3094
3095 our @SCRUBBER_ALLOWED_TAGS = qw(
3096     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3097     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
3098 );
3099
3100 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3101     # Match http, ftp and relative urls
3102     # XXX: we also scrub format strings with this module then allow simple config options
3103     href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3104     face   => 1,
3105     size   => 1,
3106     target => 1,
3107     style  => qr{
3108         ^(?:\s*
3109             (?:(?:background-)?color: \s*
3110                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
3111                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
3112                        [\w\-]+                                  # green, light-blue, etc.
3113                        )                            |
3114                text-align: \s* \w+                  |
3115                font-size: \s* [\w.\-]+              |
3116                font-family: \s* [\w\s"',.\-]+       |
3117                font-weight: \s* [\w\-]+             |
3118
3119                # MS Office styles, which are probably fine.  If we don't, then any
3120                # associated styles in the same attribute get stripped.
3121                mso-[\w\-]+?: \s* [\w\s"',.\-]+
3122             )\s* ;? \s*)
3123          +$ # one or more of these allowed properties from here 'till sunset
3124     }ix,
3125 );
3126
3127 our %SCRUBBER_RULES = ();
3128
3129 sub _NewScrubber {
3130     require HTML::Scrubber;
3131     my $scrubber = HTML::Scrubber->new();
3132     $scrubber->default(
3133         0,
3134         {
3135             %SCRUBBER_ALLOWED_ATTRIBUTES,
3136             '*' => 0, # require attributes be explicitly allowed
3137         },
3138     );
3139     $scrubber->deny(qw[*]);
3140     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3141     $scrubber->rules(%SCRUBBER_RULES);
3142
3143     # Scrubbing comments is vital since IE conditional comments can contain
3144     # arbitrary HTML and we'd pass it right on through.
3145     $scrubber->comment(0);
3146
3147     return $scrubber;
3148 }
3149
3150 =head2 JSON
3151
3152 Redispatches to L<RT::Interface::Web/EncodeJSON>
3153
3154 =cut
3155
3156 sub JSON {
3157     RT::Interface::Web::EncodeJSON(@_);
3158 }
3159
3160 package RT::Interface::Web;
3161 RT::Base->_ImportOverlays();
3162
3163 1;