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