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( 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
1255     my $uri= URI->new(shift);
1256     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1257
1258     return $uri;
1259
1260 }
1261
1262 sub IsPossibleCSRF {
1263     my $ARGS = shift;
1264
1265     # If first request on this session is to a REST endpoint, then
1266     # whitelist the REST endpoints -- and explicitly deny non-REST
1267     # endpoints.  We do this because using a REST cookie in a browser
1268     # would open the user to CSRF attacks to the REST endpoints.
1269     my $path = $HTML::Mason::Commands::r->path_info;
1270     $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1271         unless defined $HTML::Mason::Commands::session{'REST'};
1272
1273     if ($HTML::Mason::Commands::session{'REST'}) {
1274         return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1275         my $why = <<EOT;
1276 This login session belongs to a REST client, and cannot be used to
1277 access non-REST interfaces of RT for security reasons.
1278 EOT
1279         my $details = <<EOT;
1280 Please log out and back in to obtain a session for normal browsing.  If
1281 you understand the security implications, disabling RT's CSRF protection
1282 will remove this restriction.
1283 EOT
1284         chomp $details;
1285         HTML::Mason::Commands::Abort( $why, Details => $details );
1286     }
1287
1288     return 0 if IsCompCSRFWhitelisted(
1289         $HTML::Mason::Commands::m->request_comp->path,
1290         $ARGS
1291     );
1292
1293     # if there is no Referer header then assume the worst
1294     return (1,
1295             "your browser did not supply a Referrer header", # loc
1296         ) if !$ENV{HTTP_REFERER};
1297
1298     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1299     return 0 if $whitelisted;
1300
1301     if ( @$configs > 1 ) {
1302         return (1,
1303                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1304                 $browser->host_port,
1305                 shift @$configs,
1306                 join(', ', @$configs) );
1307     }
1308
1309     return (1,
1310             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1311             $browser->host_port,
1312             $configs->[0]);
1313 }
1314
1315 sub ExpandCSRFToken {
1316     my $ARGS = shift;
1317
1318     my $token = delete $ARGS->{CSRF_Token};
1319     return unless $token;
1320
1321     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1322     return unless $data;
1323     return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1324
1325     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1326     return unless $user->ValidateAuthString( $data->{auth}, $token );
1327
1328     %{$ARGS} = %{$data->{args}};
1329     $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1330
1331     # We explicitly stored file attachments with the request, but not in
1332     # the session yet, as that would itself be an attack.  Put them into
1333     # the session now, so they'll be visible.
1334     if ($data->{attach}) {
1335         my $filename = $data->{attach}{filename};
1336         my $mime     = $data->{attach}{mime};
1337         $HTML::Mason::Commands::session{'Attachments'}{$filename}
1338             = $mime;
1339     }
1340
1341     return 1;
1342 }
1343
1344 sub StoreRequestToken {
1345     my $ARGS = shift;
1346
1347     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1348     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1349     my $data = {
1350         auth => $user->GenerateAuthString( $token ),
1351         path => $HTML::Mason::Commands::r->path_info,
1352         args => $ARGS,
1353     };
1354     if ($ARGS->{Attach}) {
1355         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1356         my $file_path = delete $ARGS->{'Attach'};
1357         $data->{attach} = {
1358             filename => Encode::decode_utf8("$file_path"),
1359             mime     => $attachment,
1360         };
1361     }
1362
1363     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1364     $HTML::Mason::Commands::session{'i'}++;
1365     return $token;
1366 }
1367
1368 sub MaybeShowInterstitialCSRFPage {
1369     my $ARGS = shift;
1370
1371     return unless RT->Config->Get('RestrictReferrer');
1372
1373     # Deal with the form token provided by the interstitial, which lets
1374     # browsers which never set referer headers still use RT, if
1375     # painfully.  This blows values into ARGS
1376     return if ExpandCSRFToken($ARGS);
1377
1378     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1379     return if !$is_csrf;
1380
1381     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1382
1383     my $token = StoreRequestToken($ARGS);
1384     $HTML::Mason::Commands::m->comp(
1385         '/Elements/CSRF',
1386         OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1387         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1388         Token => $token,
1389     );
1390     # Calls abort, never gets here
1391 }
1392
1393 package HTML::Mason::Commands;
1394
1395 use vars qw/$r $m %session/;
1396
1397 sub Menu {
1398     return $HTML::Mason::Commands::m->notes('menu');
1399 }
1400
1401 sub PageMenu {
1402     return $HTML::Mason::Commands::m->notes('page-menu');
1403 }
1404
1405 sub PageWidgets {
1406     return $HTML::Mason::Commands::m->notes('page-widgets');
1407 }
1408
1409
1410
1411 =head2 loc ARRAY
1412
1413 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1414 with whatever it's called with. If there is no $session{'CurrentUser'},
1415 it creates a temporary user, so we have something to get a localisation handle
1416 through
1417
1418 =cut
1419
1420 sub loc {
1421
1422     if ( $session{'CurrentUser'}
1423         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1424     {
1425         return ( $session{'CurrentUser'}->loc(@_) );
1426     } elsif (
1427         my $u = eval {
1428             RT::CurrentUser->new();
1429         }
1430         )
1431     {
1432         return ( $u->loc(@_) );
1433     } else {
1434
1435         # pathetic case -- SystemUser is gone.
1436         return $_[0];
1437     }
1438 }
1439
1440
1441
1442 =head2 loc_fuzzy STRING
1443
1444 loc_fuzzy is for handling localizations of messages that may already
1445 contain interpolated variables, typically returned from libraries
1446 outside RT's control.  It takes the message string and extracts the
1447 variable array automatically by matching against the candidate entries
1448 inside the lexicon file.
1449
1450 =cut
1451
1452 sub loc_fuzzy {
1453     my $msg = shift;
1454
1455     if ( $session{'CurrentUser'}
1456         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1457     {
1458         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1459     } else {
1460         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1461         return ( $u->loc_fuzzy($msg) );
1462     }
1463 }
1464
1465
1466 # Error - calls Error and aborts
1467 sub Abort {
1468     my $why  = shift;
1469     my %args = @_;
1470
1471     if (   $session{'ErrorDocument'}
1472         && $session{'ErrorDocumentType'} )
1473     {
1474         $r->content_type( $session{'ErrorDocumentType'} );
1475         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1476         $m->abort;
1477     } else {
1478         $m->comp( "/Elements/Error", Why => $why, %args );
1479         $m->abort;
1480     }
1481 }
1482
1483 sub MaybeRedirectForResults {
1484     my %args = (
1485         Path      => $HTML::Mason::Commands::m->request_comp->path,
1486         Arguments => {},
1487         Anchor    => undef,
1488         Actions   => undef,
1489         Force     => 0,
1490         @_
1491     );
1492     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1493     return unless $has_actions || $args{'Force'};
1494
1495     my %arguments = %{ $args{'Arguments'} };
1496
1497     if ( $has_actions ) {
1498         my $key = Digest::MD5::md5_hex( rand(1024) );
1499         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1500         $session{'i'}++;
1501         $arguments{'results'} = $key;
1502     }
1503
1504     $args{'Path'} =~ s!^/+!!;
1505     my $url = RT->Config->Get('WebURL') . $args{Path};
1506
1507     if ( keys %arguments ) {
1508         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1509     }
1510     if ( $args{'Anchor'} ) {
1511         $url .= "#". $args{'Anchor'};
1512     }
1513     return RT::Interface::Web::Redirect($url);
1514 }
1515
1516 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1517
1518 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1519 redirect to the approvals display page, preserving any arguments.
1520
1521 C<Path>s matching C<Whitelist> are let through.
1522
1523 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1524
1525 =cut
1526
1527 sub MaybeRedirectToApproval {
1528     my %args = (
1529         Path        => $HTML::Mason::Commands::m->request_comp->path,
1530         ARGSRef     => {},
1531         Whitelist   => undef,
1532         @_
1533     );
1534
1535     return unless $ENV{REQUEST_METHOD} eq 'GET';
1536
1537     my $id = $args{ARGSRef}->{id};
1538
1539     if (    $id
1540         and RT->Config->Get('ForceApprovalsView')
1541         and not $args{Path} =~ /$args{Whitelist}/)
1542     {
1543         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1544         $ticket->Load($id);
1545
1546         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1547             MaybeRedirectForResults(
1548                 Path      => "/Approvals/Display.html",
1549                 Force     => 1,
1550                 Anchor    => $args{ARGSRef}->{Anchor},
1551                 Arguments => $args{ARGSRef},
1552             );
1553         }
1554     }
1555 }
1556
1557 =head2 CreateTicket ARGS
1558
1559 Create a new ticket, using Mason's %ARGS.  returns @results.
1560
1561 =cut
1562
1563 sub CreateTicket {
1564     my %ARGS = (@_);
1565
1566     my (@Actions);
1567
1568     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1569
1570     my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1571     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1572         Abort('Queue not found');
1573     }
1574
1575     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1576         Abort('You have no permission to create tickets in that queue.');
1577     }
1578
1579     my $due;
1580     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1581         $due = RT::Date->new( $session{'CurrentUser'} );
1582         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1583     }
1584     my $starts;
1585     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1586         $starts = RT::Date->new( $session{'CurrentUser'} );
1587         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1588     }
1589
1590     my $sigless = RT::Interface::Web::StripContent(
1591         Content        => $ARGS{Content},
1592         ContentType    => $ARGS{ContentType},
1593         StripSignature => 1,
1594         CurrentUser    => $session{'CurrentUser'},
1595     );
1596
1597     my $MIMEObj = MakeMIMEEntity(
1598         Subject => $ARGS{'Subject'},
1599         From    => $ARGS{'From'},
1600         Cc      => $ARGS{'Cc'},
1601         Body    => $sigless,
1602         Type    => $ARGS{'ContentType'},
1603     );
1604
1605     if ( $ARGS{'Attachments'} ) {
1606         my $rv = $MIMEObj->make_multipart;
1607         $RT::Logger->error("Couldn't make multipart message")
1608             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1609
1610         foreach ( values %{ $ARGS{'Attachments'} } ) {
1611             unless ($_) {
1612                 $RT::Logger->error("Couldn't add empty attachemnt");
1613                 next;
1614             }
1615             $MIMEObj->add_part($_);
1616         }
1617     }
1618
1619     foreach my $argument (qw(Encrypt Sign)) {
1620         $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1621           if defined $ARGS{$argument};
1622     }
1623
1624     my %create_args = (
1625         Type => $ARGS{'Type'} || 'ticket',
1626         Queue => $ARGS{'Queue'},
1627         Owner => $ARGS{'Owner'},
1628
1629         # note: name change
1630         Requestor       => $ARGS{'Requestors'},
1631         Cc              => $ARGS{'Cc'},
1632         AdminCc         => $ARGS{'AdminCc'},
1633         InitialPriority => $ARGS{'InitialPriority'},
1634         FinalPriority   => $ARGS{'FinalPriority'},
1635         TimeLeft        => $ARGS{'TimeLeft'},
1636         TimeEstimated   => $ARGS{'TimeEstimated'},
1637         TimeWorked      => $ARGS{'TimeWorked'},
1638         Subject         => $ARGS{'Subject'},
1639         Status          => $ARGS{'Status'},
1640         Due             => $due ? $due->ISO : undef,
1641         Starts          => $starts ? $starts->ISO : undef,
1642         MIMEObj         => $MIMEObj
1643     );
1644
1645     my @txn_squelch;
1646     foreach my $type (qw(Requestor Cc AdminCc)) {
1647         push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1648             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1649     }
1650     $create_args{TransSquelchMailTo} = \@txn_squelch
1651         if @txn_squelch;
1652
1653     if ( $ARGS{'AttachTickets'} ) {
1654         require RT::Action::SendEmail;
1655         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1656             ref $ARGS{'AttachTickets'}
1657             ? @{ $ARGS{'AttachTickets'} }
1658             : ( $ARGS{'AttachTickets'} ) );
1659     }
1660
1661     foreach my $arg ( keys %ARGS ) {
1662         next if $arg =~ /-(?:Magic|Category)$/;
1663
1664         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1665             $create_args{$arg} = $ARGS{$arg};
1666         }
1667
1668         # Object-RT::Ticket--CustomField-3-Values
1669         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1670             my $cfid = $1;
1671
1672             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1673             $cf->SetContextObject( $Queue );
1674             $cf->Load($cfid);
1675             unless ( $cf->id ) {
1676                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1677                 next;
1678             }
1679
1680             if ( $arg =~ /-Upload$/ ) {
1681                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1682                 next;
1683             }
1684
1685             my $type = $cf->Type;
1686
1687             my @values = ();
1688             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1689                 @values = @{ $ARGS{$arg} };
1690             } elsif ( $type =~ /text/i ) {
1691                 @values = ( $ARGS{$arg} );
1692             } else {
1693                 no warnings 'uninitialized';
1694                 @values = split /\r*\n/, $ARGS{$arg};
1695             }
1696             @values = grep length, map {
1697                 s/\r+\n/\n/g;
1698                 s/^\s+//;
1699                 s/\s+$//;
1700                 $_;
1701                 }
1702                 grep defined, @values;
1703
1704             $create_args{"CustomField-$cfid"} = \@values;
1705         }
1706     }
1707
1708     # turn new link lists into arrays, and pass in the proper arguments
1709     my %map = (
1710         'new-DependsOn' => 'DependsOn',
1711         'DependsOn-new' => 'DependedOnBy',
1712         'new-MemberOf'  => 'Parents',
1713         'MemberOf-new'  => 'Children',
1714         'new-RefersTo'  => 'RefersTo',
1715         'RefersTo-new'  => 'ReferredToBy',
1716     );
1717     foreach my $key ( keys %map ) {
1718         next unless $ARGS{$key};
1719         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1720
1721     }
1722
1723     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1724     unless ($id) {
1725         Abort($ErrMsg);
1726     }
1727
1728     push( @Actions, split( "\n", $ErrMsg ) );
1729     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1730         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1731     }
1732     return ( $Ticket, @Actions );
1733
1734 }
1735
1736
1737
1738 =head2  LoadTicket id
1739
1740 Takes a ticket id as its only variable. if it's handed an array, it takes
1741 the first value.
1742
1743 Returns an RT::Ticket object as the current user.
1744
1745 =cut
1746
1747 sub LoadTicket {
1748     my $id = shift;
1749
1750     if ( ref($id) eq "ARRAY" ) {
1751         $id = $id->[0];
1752     }
1753
1754     unless ($id) {
1755         Abort("No ticket specified");
1756     }
1757
1758     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1759     $Ticket->Load($id);
1760     unless ( $Ticket->id ) {
1761         Abort("Could not load ticket $id");
1762     }
1763     return $Ticket;
1764 }
1765
1766
1767
1768 =head2 ProcessUpdateMessage
1769
1770 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1771
1772 Don't write message if it only contains current user's signature and
1773 SkipSignatureOnly argument is true. Function anyway adds attachments
1774 and updates time worked field even if skips message. The default value
1775 is true.
1776
1777 =cut
1778
1779 sub ProcessUpdateMessage {
1780
1781     my %args = (
1782         ARGSRef           => undef,
1783         TicketObj         => undef,
1784         SkipSignatureOnly => 1,
1785         @_
1786     );
1787
1788     if ( $args{ARGSRef}->{'UpdateAttachments'}
1789         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1790     {
1791         delete $args{ARGSRef}->{'UpdateAttachments'};
1792     }
1793
1794     # Strip the signature
1795     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1796         Content        => $args{ARGSRef}->{UpdateContent},
1797         ContentType    => $args{ARGSRef}->{UpdateContentType},
1798         StripSignature => $args{SkipSignatureOnly},
1799         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1800     );
1801
1802     # If, after stripping the signature, we have no message, move the
1803     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1804     # ProcessBasics can deal -- then bail out.
1805     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1806         and not length $args{ARGSRef}->{'UpdateContent'} )
1807     {
1808         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1809             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1810         }
1811         return;
1812     }
1813
1814     if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1815         $args{ARGSRef}->{'UpdateSubject'} = undef;
1816     }
1817
1818     my $Message = MakeMIMEEntity(
1819         Subject => $args{ARGSRef}->{'UpdateSubject'},
1820         Body    => $args{ARGSRef}->{'UpdateContent'},
1821         Type    => $args{ARGSRef}->{'UpdateContentType'},
1822     );
1823
1824     $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1825         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1826     ) );
1827     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1828     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1829         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1830     } else {
1831         $old_txn = $args{TicketObj}->Transactions->First();
1832     }
1833
1834     if ( my $msg = $old_txn->Message->First ) {
1835         RT::Interface::Email::SetInReplyTo(
1836             Message   => $Message,
1837             InReplyTo => $msg
1838         );
1839     }
1840
1841     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1842         $Message->make_multipart;
1843         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1844     }
1845
1846     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1847         require RT::Action::SendEmail;
1848         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1849             ref $args{ARGSRef}->{'AttachTickets'}
1850             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1851             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1852     }
1853
1854     my %txn_customfields;
1855
1856     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1857       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1858         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1859       }
1860     }
1861
1862     my %message_args = (
1863         Sign         => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1864         Encrypt      => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1865         MIMEObj      => $Message,
1866         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1867         CustomFields => \%txn_customfields,
1868     );
1869
1870     _ProcessUpdateMessageRecipients(
1871         MessageArgs => \%message_args,
1872         %args,
1873     );
1874
1875     my @results;
1876     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1877         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1878         push( @results, $Description );
1879         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1880     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1881         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1882         push( @results, $Description );
1883         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1884     } else {
1885         push( @results,
1886             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1887     }
1888     return @results;
1889 }
1890
1891 sub _ProcessUpdateMessageRecipients {
1892     my %args = (
1893         ARGSRef           => undef,
1894         TicketObj         => undef,
1895         MessageArgs       => undef,
1896         @_,
1897     );
1898
1899     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1900     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1901
1902     my $message_args = $args{MessageArgs};
1903
1904     $message_args->{CcMessageTo} = $cc;
1905     $message_args->{BccMessageTo} = $bcc;
1906
1907     my @txn_squelch;
1908     foreach my $type (qw(Cc AdminCc)) {
1909         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1910             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1911             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1912             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1913         }
1914     }
1915     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1916         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1917         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1918
1919     }
1920
1921     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1922     $message_args->{SquelchMailTo} = \@txn_squelch
1923         if @txn_squelch;
1924
1925     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1926         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1927             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1928
1929             my $var   = ucfirst($1) . 'MessageTo';
1930             my $value = $2;
1931             if ( $message_args->{$var} ) {
1932                 $message_args->{$var} .= ", $value";
1933             } else {
1934                 $message_args->{$var} = $value;
1935             }
1936         }
1937     }
1938 }
1939
1940 =head2 MakeMIMEEntity PARAMHASH
1941
1942 Takes a paramhash Subject, Body and AttachmentFieldName.
1943
1944 Also takes Form, Cc and Type as optional paramhash keys.
1945
1946   Returns a MIME::Entity.
1947
1948 =cut
1949
1950 sub MakeMIMEEntity {
1951
1952     #TODO document what else this takes.
1953     my %args = (
1954         Subject             => undef,
1955         From                => undef,
1956         Cc                  => undef,
1957         Body                => undef,
1958         AttachmentFieldName => undef,
1959         Type                => undef,
1960         @_,
1961     );
1962     my $Message = MIME::Entity->build(
1963         Type    => 'multipart/mixed',
1964         "Message-Id" => RT::Interface::Email::GenMessageId,
1965         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1966             grep defined $args{$_}, qw(Subject From Cc)
1967     );
1968
1969     if ( defined $args{'Body'} && length $args{'Body'} ) {
1970
1971         # Make the update content have no 'weird' newlines in it
1972         $args{'Body'} =~ s/\r\n/\n/gs;
1973
1974         $Message->attach(
1975             Type    => $args{'Type'} || 'text/plain',
1976             Charset => 'UTF-8',
1977             Data    => $args{'Body'},
1978         );
1979     }
1980
1981     if ( $args{'AttachmentFieldName'} ) {
1982
1983         my $cgi_object = $m->cgi_object;
1984         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1985         if ( defined $filehandle && length $filehandle ) {
1986
1987             my ( @content, $buffer );
1988             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1989                 push @content, $buffer;
1990             }
1991
1992             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1993
1994             my $filename = "$filehandle";
1995             $filename =~ s{^.*[\\/]}{};
1996
1997             $Message->attach(
1998                 Type     => $uploadinfo->{'Content-Type'},
1999                 Filename => $filename,
2000                 Data     => \@content,
2001             );
2002             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2003                 $Message->head->set( 'Subject' => $filename );
2004             }
2005
2006             # Attachment parts really shouldn't get a Message-ID
2007             $Message->head->delete('Message-ID');
2008         }
2009     }
2010
2011     $Message->make_singlepart;
2012
2013     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2014
2015     return ($Message);
2016
2017 }
2018
2019
2020
2021 =head2 ParseDateToISO
2022
2023 Takes a date in an arbitrary format.
2024 Returns an ISO date and time in GMT
2025
2026 =cut
2027
2028 sub ParseDateToISO {
2029     my $date = shift;
2030
2031     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2032     $date_obj->Set(
2033         Format => 'unknown',
2034         Value  => $date
2035     );
2036     return ( $date_obj->ISO );
2037 }
2038
2039
2040
2041 sub ProcessACLChanges {
2042     my $ARGSref = shift;
2043
2044     my @results;
2045
2046     foreach my $arg ( keys %$ARGSref ) {
2047         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2048
2049         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2050
2051         my @rights;
2052         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2053             @rights = @{ $ARGSref->{$arg} };
2054         } else {
2055             @rights = $ARGSref->{$arg};
2056         }
2057         @rights = grep $_, @rights;
2058         next unless @rights;
2059
2060         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2061         $principal->Load($principal_id);
2062
2063         my $obj;
2064         if ( $object_type eq 'RT::System' ) {
2065             $obj = $RT::System;
2066         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2067             $obj = $object_type->new( $session{'CurrentUser'} );
2068             $obj->Load($object_id);
2069             unless ( $obj->id ) {
2070                 $RT::Logger->error("couldn't load $object_type #$object_id");
2071                 next;
2072             }
2073         } else {
2074             $RT::Logger->error("object type '$object_type' is incorrect");
2075             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2076             next;
2077         }
2078
2079         foreach my $right (@rights) {
2080             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2081             push( @results, $msg );
2082         }
2083     }
2084
2085     return (@results);
2086 }
2087
2088
2089 =head2 ProcessACLs
2090
2091 ProcessACLs expects values from a series of checkboxes that describe the full
2092 set of rights a principal should have on an object.
2093
2094 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2095 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2096 listing the rights the principal should have, and ProcessACLs will modify the
2097 current rights to match.  Additionally, the previously unused CheckACL input
2098 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2099 rights are removed from a principal and as such no SetRights input is
2100 submitted.
2101
2102 =cut
2103
2104 sub ProcessACLs {
2105     my $ARGSref = shift;
2106     my (%state, @results);
2107
2108     my $CheckACL = $ARGSref->{'CheckACL'};
2109     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2110
2111     # Check if we want to grant rights to a previously rights-less user
2112     for my $type (qw(user group)) {
2113         my $key = "AddPrincipalForRights-$type";
2114
2115         next unless $ARGSref->{$key};
2116
2117         my $principal;
2118         if ( $type eq 'user' ) {
2119             $principal = RT::User->new( $session{'CurrentUser'} );
2120             $principal->LoadByCol( Name => $ARGSref->{$key} );
2121         }
2122         else {
2123             $principal = RT::Group->new( $session{'CurrentUser'} );
2124             $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2125         }
2126
2127         unless ($principal->PrincipalId) {
2128             push @results, loc("Couldn't load the specified principal");
2129             next;
2130         }
2131
2132         my $principal_id = $principal->PrincipalId;
2133
2134         # Turn our addprincipal rights spec into a real one
2135         for my $arg (keys %$ARGSref) {
2136             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2137
2138             my $tuple = "$principal_id-$1";
2139             my $key   = "SetRights-$tuple";
2140
2141             # If we have it already, that's odd, but merge them
2142             if (grep { $_ eq $tuple } @check) {
2143                 $ARGSref->{$key} = [
2144                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2145                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2146                 ];
2147             } else {
2148                 $ARGSref->{$key} = $ARGSref->{$arg};
2149                 push @check, $tuple;
2150             }
2151         }
2152     }
2153
2154     # Build our rights state for each Principal-Object tuple
2155     foreach my $arg ( keys %$ARGSref ) {
2156         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2157
2158         my $tuple  = $1;
2159         my $value  = $ARGSref->{$arg};
2160         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2161         next unless @rights;
2162
2163         $state{$tuple} = { map { $_ => 1 } @rights };
2164     }
2165
2166     foreach my $tuple (List::MoreUtils::uniq @check) {
2167         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2168
2169         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2170
2171         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2172         $principal->Load($principal_id);
2173
2174         my $obj;
2175         if ( $object_type eq 'RT::System' ) {
2176             $obj = $RT::System;
2177         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2178             $obj = $object_type->new( $session{'CurrentUser'} );
2179             $obj->Load($object_id);
2180             unless ( $obj->id ) {
2181                 $RT::Logger->error("couldn't load $object_type #$object_id");
2182                 next;
2183             }
2184         } else {
2185             $RT::Logger->error("object type '$object_type' is incorrect");
2186             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2187             next;
2188         }
2189
2190         my $acls = RT::ACL->new($session{'CurrentUser'});
2191         $acls->LimitToObject( $obj );
2192         $acls->LimitToPrincipal( Id => $principal_id );
2193
2194         while ( my $ace = $acls->Next ) {
2195             my $right = $ace->RightName;
2196
2197             # Has right and should have right
2198             next if delete $state{$tuple}->{$right};
2199
2200             # Has right and shouldn't have right
2201             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2202             push @results, $msg;
2203         }
2204
2205         # For everything left, they don't have the right but they should
2206         for my $right (keys %{ $state{$tuple} || {} }) {
2207             delete $state{$tuple}->{$right};
2208             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2209             push @results, $msg;
2210         }
2211
2212         # Check our state for leftovers
2213         if ( keys %{ $state{$tuple} || {} } ) {
2214             my $missed = join '|', %{$state{$tuple} || {}};
2215             $RT::Logger->warn(
2216                "Uh-oh, it looks like we somehow missed a right in "
2217               ."ProcessACLs.  Here's what was leftover: $missed"
2218             );
2219         }
2220     }
2221
2222     return (@results);
2223 }
2224
2225
2226
2227
2228 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2229
2230 @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.
2231
2232 Returns an array of success/failure messages
2233
2234 =cut
2235
2236 sub UpdateRecordObject {
2237     my %args = (
2238         ARGSRef         => undef,
2239         AttributesRef   => undef,
2240         Object          => undef,
2241         AttributePrefix => undef,
2242         @_
2243     );
2244
2245     my $Object  = $args{'Object'};
2246     my @results = $Object->Update(
2247         AttributesRef   => $args{'AttributesRef'},
2248         ARGSRef         => $args{'ARGSRef'},
2249         AttributePrefix => $args{'AttributePrefix'},
2250     );
2251
2252     return (@results);
2253 }
2254
2255
2256
2257 sub ProcessCustomFieldUpdates {
2258     my %args = (
2259         CustomFieldObj => undef,
2260         ARGSRef        => undef,
2261         @_
2262     );
2263
2264     my $Object  = $args{'CustomFieldObj'};
2265     my $ARGSRef = $args{'ARGSRef'};
2266
2267     my @attribs = qw(Name Type Description Queue SortOrder);
2268     my @results = UpdateRecordObject(
2269         AttributesRef => \@attribs,
2270         Object        => $Object,
2271         ARGSRef       => $ARGSRef
2272     );
2273
2274     my $prefix = "CustomField-" . $Object->Id;
2275     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2276         my ( $addval, $addmsg ) = $Object->AddValue(
2277             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2278             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2279             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2280         );
2281         push( @results, $addmsg );
2282     }
2283
2284     my @delete_values
2285         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2286         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2287         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2288
2289     foreach my $id (@delete_values) {
2290         next unless defined $id;
2291         my ( $err, $msg ) = $Object->DeleteValue($id);
2292         push( @results, $msg );
2293     }
2294
2295     my $vals = $Object->Values();
2296     while ( my $cfv = $vals->Next() ) {
2297         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2298             if ( $cfv->SortOrder != $so ) {
2299                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2300                 push( @results, $msg );
2301             }
2302         }
2303     }
2304
2305     return (@results);
2306 }
2307
2308
2309
2310 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2311
2312 Returns an array of results messages.
2313
2314 =cut
2315
2316 sub ProcessTicketBasics {
2317
2318     my %args = (
2319         TicketObj => undef,
2320         ARGSRef   => undef,
2321         @_
2322     );
2323
2324     my $TicketObj = $args{'TicketObj'};
2325     my $ARGSRef   = $args{'ARGSRef'};
2326
2327     my $OrigOwner = $TicketObj->Owner;
2328
2329     # Set basic fields
2330     my @attribs = qw(
2331         Subject
2332         FinalPriority
2333         Priority
2334         TimeEstimated
2335         TimeWorked
2336         TimeLeft
2337         Type
2338         Status
2339         Queue
2340     );
2341
2342     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2343     for my $field (qw(Queue Owner)) {
2344         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2345             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2346             my $temp = $class->new(RT->SystemUser);
2347             $temp->Load( $ARGSRef->{$field} );
2348             if ( $temp->id ) {
2349                 $ARGSRef->{$field} = $temp->id;
2350             }
2351         }
2352     }
2353
2354     # Status isn't a field that can be set to a null value.
2355     # RT core complains if you try
2356     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2357
2358     my @results = UpdateRecordObject(
2359         AttributesRef => \@attribs,
2360         Object        => $TicketObj,
2361         ARGSRef       => $ARGSRef,
2362     );
2363
2364     # We special case owner changing, so we can use ForceOwnerChange
2365     if ( $ARGSRef->{'Owner'}
2366       && $ARGSRef->{'Owner'} !~ /\D/
2367       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2368         my ($ChownType);
2369         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2370             $ChownType = "Force";
2371         }
2372         else {
2373             $ChownType = "Set";
2374         }
2375
2376         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2377         push( @results, $msg );
2378     }
2379
2380     # }}}
2381
2382     return (@results);
2383 }
2384
2385 sub ProcessTicketReminders {
2386     my %args = (
2387         TicketObj => undef,
2388         ARGSRef   => undef,
2389         @_
2390     );
2391
2392     my $Ticket = $args{'TicketObj'};
2393     my $args   = $args{'ARGSRef'};
2394     my @results;
2395
2396     my $reminder_collection = $Ticket->Reminders->Collection;
2397
2398     if ( $args->{'update-reminders'} ) {
2399         while ( my $reminder = $reminder_collection->Next ) {
2400             my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2401             if (   $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2402                 $Ticket->Reminders->Resolve($reminder);
2403             }
2404             elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2405                 $Ticket->Reminders->Open($reminder);
2406             }
2407
2408             if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2409                 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2410             }
2411
2412             if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2413                 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2414             }
2415
2416             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2417                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2418                 $DateObj->Set(
2419                     Format => 'unknown',
2420                     Value  => $args->{ 'Reminder-Due-' . $reminder->id }
2421                 );
2422                 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2423                     $reminder->SetDue( $DateObj->ISO );
2424                 }
2425             }
2426         }
2427     }
2428
2429     if ( $args->{'NewReminder-Subject'} ) {
2430         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2431         $due_obj->Set(
2432           Format => 'unknown',
2433           Value => $args->{'NewReminder-Due'}
2434         );
2435         my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2436             Subject => $args->{'NewReminder-Subject'},
2437             Owner   => $args->{'NewReminder-Owner'},
2438             Due     => $due_obj->ISO
2439         );
2440         push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2441     }
2442     return @results;
2443 }
2444
2445 sub ProcessTicketCustomFieldUpdates {
2446     my %args = @_;
2447     $args{'Object'} = delete $args{'TicketObj'};
2448     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2449
2450     # Build up a list of objects that we want to work with
2451     my %custom_fields_to_mod;
2452     foreach my $arg ( keys %$ARGSRef ) {
2453         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2454             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2455         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2456             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2457         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2458             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2459         }
2460     }
2461
2462     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2463 }
2464
2465 sub ProcessObjectCustomFieldUpdates {
2466     my %args    = @_;
2467     my $ARGSRef = $args{'ARGSRef'};
2468     my @results;
2469
2470     # Build up a list of objects that we want to work with
2471     my %custom_fields_to_mod;
2472     foreach my $arg ( keys %$ARGSRef ) {
2473
2474         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2475         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2476
2477         # For each of those objects, find out what custom fields we want to work with.
2478         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2479     }
2480
2481     # For each of those objects
2482     foreach my $class ( keys %custom_fields_to_mod ) {
2483         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2484             my $Object = $args{'Object'};
2485             $Object = $class->new( $session{'CurrentUser'} )
2486                 unless $Object && ref $Object eq $class;
2487
2488             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2489             unless ( $Object->id ) {
2490                 $RT::Logger->warning("Couldn't load object $class #$id");
2491                 next;
2492             }
2493
2494             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2495                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2496                 $CustomFieldObj->SetContextObject($Object);
2497                 $CustomFieldObj->LoadById($cf);
2498                 unless ( $CustomFieldObj->id ) {
2499                     $RT::Logger->warning("Couldn't load custom field #$cf");
2500                     next;
2501                 }
2502                 push @results,
2503                     _ProcessObjectCustomFieldUpdates(
2504                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2505                     Object      => $Object,
2506                     CustomField => $CustomFieldObj,
2507                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2508                     );
2509             }
2510         }
2511     }
2512     return @results;
2513 }
2514
2515 sub _ProcessObjectCustomFieldUpdates {
2516     my %args    = @_;
2517     my $cf      = $args{'CustomField'};
2518     my $cf_type = $cf->Type || '';
2519
2520     # Remove blank Values since the magic field will take care of this. Sometimes
2521     # the browser gives you a blank value which causes CFs to be processed twice
2522     if (   defined $args{'ARGS'}->{'Values'}
2523         && !length $args{'ARGS'}->{'Values'}
2524         && $args{'ARGS'}->{'Values-Magic'} )
2525     {
2526         delete $args{'ARGS'}->{'Values'};
2527     }
2528
2529     my @results;
2530     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2531
2532         # skip category argument
2533         next if $arg eq 'Category';
2534
2535         # and TimeUnits
2536         next if $arg eq 'Value-TimeUnits';
2537
2538         # since http won't pass in a form element with a null value, we need
2539         # to fake it
2540         if ( $arg eq 'Values-Magic' ) {
2541
2542             # We don't care about the magic, if there's really a values element;
2543             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2544             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2545
2546             # "Empty" values does not mean anything for Image and Binary fields
2547             next if $cf_type =~ /^(?:Image|Binary)$/;
2548
2549             $arg = 'Values';
2550             $args{'ARGS'}->{'Values'} = undef;
2551         }
2552
2553         my @values = ();
2554         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2555             @values = @{ $args{'ARGS'}->{$arg} };
2556         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2557             @values = ( $args{'ARGS'}->{$arg} );
2558         } else {
2559             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2560                 if defined $args{'ARGS'}->{$arg};
2561         }
2562         @values = grep length, map {
2563             s/\r+\n/\n/g;
2564             s/^\s+//;
2565             s/\s+$//;
2566             $_;
2567             }
2568             grep defined, @values;
2569
2570         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2571             foreach my $value (@values) {
2572                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2573                     Field => $cf->id,
2574                     Value => $value
2575                 );
2576                 push( @results, $msg );
2577             }
2578         } elsif ( $arg eq 'Upload' ) {
2579             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2580             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2581             push( @results, $msg );
2582         } elsif ( $arg eq 'DeleteValues' ) {
2583             foreach my $value (@values) {
2584                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2585                     Field => $cf,
2586                     Value => $value,
2587                 );
2588                 push( @results, $msg );
2589             }
2590         } elsif ( $arg eq 'DeleteValueIds' ) {
2591             foreach my $value (@values) {
2592                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2593                     Field   => $cf,
2594                     ValueId => $value,
2595                 );
2596                 push( @results, $msg );
2597             }
2598         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2599             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2600
2601             my %values_hash;
2602             foreach my $value (@values) {
2603                 if ( my $entry = $cf_values->HasEntry($value) ) {
2604                     $values_hash{ $entry->id } = 1;
2605                     next;
2606                 }
2607
2608                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2609                     Field => $cf,
2610                     Value => $value
2611                 );
2612                 push( @results, $msg );
2613                 $values_hash{$val} = 1 if $val;
2614             }
2615
2616             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2617             return @results if ( $cf->Type eq 'Date' && ! @values );
2618
2619             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2620             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2621
2622             $cf_values->RedoSearch;
2623             while ( my $cf_value = $cf_values->Next ) {
2624                 next if $values_hash{ $cf_value->id };
2625
2626                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2627                     Field   => $cf,
2628                     ValueId => $cf_value->id
2629                 );
2630                 push( @results, $msg );
2631             }
2632         } elsif ( $arg eq 'Values' ) {
2633             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2634
2635             # keep everything up to the point of difference, delete the rest
2636             my $delete_flag;
2637             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2638                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2639                     shift @values;
2640                     next;
2641                 }
2642
2643                 $delete_flag ||= 1;
2644                 $old_cf->Delete;
2645             }
2646
2647             # now add/replace extra things, if any
2648             foreach my $value (@values) {
2649                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2650                     Field => $cf,
2651                     Value => $value
2652                 );
2653                 push( @results, $msg );
2654             }
2655         } else {
2656             push(
2657                 @results,
2658                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2659                     $cf->Name, ref $args{'Object'},
2660                     $args{'Object'}->id
2661                 )
2662             );
2663         }
2664     }
2665     return @results;
2666 }
2667
2668
2669 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2670
2671 Returns an array of results messages.
2672
2673 =cut
2674
2675 sub ProcessTicketWatchers {
2676     my %args = (
2677         TicketObj => undef,
2678         ARGSRef   => undef,
2679         @_
2680     );
2681     my (@results);
2682
2683     my $Ticket  = $args{'TicketObj'};
2684     my $ARGSRef = $args{'ARGSRef'};
2685
2686     # Munge watchers
2687
2688     foreach my $key ( keys %$ARGSRef ) {
2689
2690         # Delete deletable watchers
2691         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2692             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2693                 PrincipalId => $2,
2694                 Type        => $1
2695             );
2696             push @results, $msg;
2697         }
2698
2699         # Delete watchers in the simple style demanded by the bulk manipulator
2700         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2701             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2702                 Email => $ARGSRef->{$key},
2703                 Type  => $1
2704             );
2705             push @results, $msg;
2706         }
2707
2708         # Add new wathchers by email address
2709         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2710             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2711         {
2712
2713             #They're in this order because otherwise $1 gets clobbered :/
2714             my ( $code, $msg ) = $Ticket->AddWatcher(
2715                 Type  => $ARGSRef->{$key},
2716                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2717             );
2718             push @results, $msg;
2719         }
2720
2721         #Add requestors in the simple style demanded by the bulk manipulator
2722         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2723             my ( $code, $msg ) = $Ticket->AddWatcher(
2724                 Type  => $1,
2725                 Email => $ARGSRef->{$key}
2726             );
2727             push @results, $msg;
2728         }
2729
2730         # Add new  watchers by owner
2731         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2732             my $principal_id = $1;
2733             my $form         = $ARGSRef->{$key};
2734             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2735                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2736
2737                 my ( $code, $msg ) = $Ticket->AddWatcher(
2738                     Type        => $value,
2739                     PrincipalId => $principal_id
2740                 );
2741                 push @results, $msg;
2742             }
2743         }
2744
2745     }
2746     return (@results);
2747 }
2748
2749
2750
2751 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2752
2753 Returns an array of results messages.
2754
2755 =cut
2756
2757 sub ProcessTicketDates {
2758     my %args = (
2759         TicketObj => undef,
2760         ARGSRef   => undef,
2761         @_
2762     );
2763
2764     my $Ticket  = $args{'TicketObj'};
2765     my $ARGSRef = $args{'ARGSRef'};
2766
2767     my (@results);
2768
2769     # Set date fields
2770     my @date_fields = qw(
2771         Told
2772         Resolved
2773         Starts
2774         Started
2775         Due
2776     );
2777
2778     #Run through each field in this list. update the value if apropriate
2779     foreach my $field (@date_fields) {
2780         next unless exists $ARGSRef->{ $field . '_Date' };
2781         next if $ARGSRef->{ $field . '_Date' } eq '';
2782
2783         my ( $code, $msg );
2784
2785         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2786         $DateObj->Set(
2787             Format => 'unknown',
2788             Value  => $ARGSRef->{ $field . '_Date' }
2789         );
2790
2791         my $obj = $field . "Obj";
2792         if (    ( defined $DateObj->Unix )
2793             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2794         {
2795             my $method = "Set$field";
2796             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2797             push @results, "$msg";
2798         }
2799     }
2800
2801     # }}}
2802     return (@results);
2803 }
2804
2805
2806
2807 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2808
2809 Returns an array of results messages.
2810
2811 =cut
2812
2813 sub ProcessTicketLinks {
2814     my %args = (
2815         TicketObj => undef,
2816         ARGSRef   => undef,
2817         @_
2818     );
2819
2820     my $Ticket  = $args{'TicketObj'};
2821     my $ARGSRef = $args{'ARGSRef'};
2822
2823     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2824
2825     #Merge if we need to
2826     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2827         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2828         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2829         push @results, $msg;
2830     }
2831
2832     return (@results);
2833 }
2834
2835
2836 sub ProcessRecordLinks {
2837     my %args = (
2838         RecordObj => undef,
2839         ARGSRef   => undef,
2840         @_
2841     );
2842
2843     my $Record  = $args{'RecordObj'};
2844     my $ARGSRef = $args{'ARGSRef'};
2845
2846     my (@results);
2847
2848     # Delete links that are gone gone gone.
2849     foreach my $arg ( keys %$ARGSRef ) {
2850         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2851             my $base   = $1;
2852             my $type   = $2;
2853             my $target = $3;
2854
2855             my ( $val, $msg ) = $Record->DeleteLink(
2856                 Base   => $base,
2857                 Type   => $type,
2858                 Target => $target
2859             );
2860
2861             push @results, $msg;
2862
2863         }
2864
2865     }
2866
2867     my @linktypes = qw( DependsOn MemberOf RefersTo );
2868
2869     foreach my $linktype (@linktypes) {
2870         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2871             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2872                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2873
2874             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2875                 next unless $luri;
2876                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2877                 my ( $val, $msg ) = $Record->AddLink(
2878                     Target => $luri,
2879                     Type   => $linktype
2880                 );
2881                 push @results, $msg;
2882             }
2883         }
2884         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2885             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2886                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2887
2888             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2889                 next unless $luri;
2890                 my ( $val, $msg ) = $Record->AddLink(
2891                     Base => $luri,
2892                     Type => $linktype
2893                 );
2894
2895                 push @results, $msg;
2896             }
2897         }
2898     }
2899
2900     return (@results);
2901 }
2902
2903 =head2 _UploadedFile ( $arg );
2904
2905 Takes a CGI parameter name; if a file is uploaded under that name,
2906 return a hash reference suitable for AddCustomFieldValue's use:
2907 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2908
2909 Returns C<undef> if no files were uploaded in the C<$arg> field.
2910
2911 =cut
2912
2913 sub _UploadedFile {
2914     my $arg         = shift;
2915     my $cgi_object  = $m->cgi_object;
2916     my $fh          = $cgi_object->upload($arg) or return undef;
2917     my $upload_info = $cgi_object->uploadInfo($fh);
2918
2919     my $filename = "$fh";
2920     $filename =~ s#^.*[\\/]##;
2921     binmode($fh);
2922
2923     return {
2924         Value        => $filename,
2925         LargeContent => do { local $/; scalar <$fh> },
2926         ContentType  => $upload_info->{'Content-Type'},
2927     };
2928 }
2929
2930 sub GetColumnMapEntry {
2931     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2932
2933     # deal with the simplest thing first
2934     if ( $args{'Map'}{ $args{'Name'} } ) {
2935         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2936     }
2937
2938     # complex things
2939     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2940         return undef unless $args{'Map'}->{$mainkey};
2941         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2942             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2943
2944         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2945     }
2946     return undef;
2947 }
2948
2949 sub ProcessColumnMapValue {
2950     my $value = shift;
2951     my %args = ( Arguments => [], Escape => 1, @_ );
2952
2953     if ( ref $value ) {
2954         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2955             my @tmp = $value->( @{ $args{'Arguments'} } );
2956             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2957         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2958             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2959         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2960             return $$value;
2961         }
2962     }
2963
2964     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2965     return $value;
2966 }
2967
2968 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2969
2970 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2971 principal collections mapped from the categories given.
2972
2973 =cut
2974
2975 sub GetPrincipalsMap {
2976     my $object = shift;
2977     my @map;
2978     for (@_) {
2979         if (/System/) {
2980             my $system = RT::Groups->new($session{'CurrentUser'});
2981             $system->LimitToSystemInternalGroups();
2982             $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2983             push @map, [
2984                 'System' => $system,    # loc_left_pair
2985                 'Type'   => 1,
2986             ];
2987         }
2988         elsif (/Groups/) {
2989             my $groups = RT::Groups->new($session{'CurrentUser'});
2990             $groups->LimitToUserDefinedGroups();
2991             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2992
2993             # Only show groups who have rights granted on this object
2994             $groups->WithGroupRight(
2995                 Right   => '',
2996                 Object  => $object,
2997                 IncludeSystemRights => 0,
2998                 IncludeSubgroupMembers => 0,
2999             );
3000
3001             push @map, [
3002                 'User Groups' => $groups,   # loc_left_pair
3003                 'Name'        => 0
3004             ];
3005         }
3006         elsif (/Roles/) {
3007             my $roles = RT::Groups->new($session{'CurrentUser'});
3008
3009             if ($object->isa('RT::System')) {
3010                 $roles->LimitToRolesForSystem();
3011             }
3012             elsif ($object->isa('RT::Queue')) {
3013                 $roles->LimitToRolesForQueue($object->Id);
3014             }
3015             else {
3016                 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3017                 next;
3018             }
3019             $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3020             push @map, [
3021                 'Roles' => $roles,  # loc_left_pair
3022                 'Type'  => 1
3023             ];
3024         }
3025         elsif (/Users/) {
3026             my $Users = RT->PrivilegedUsers->UserMembersObj();
3027             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3028
3029             # Only show users who have rights granted on this object
3030             my $group_members = $Users->WhoHaveGroupRight(
3031                 Right   => '',
3032                 Object  => $object,
3033                 IncludeSystemRights => 0,
3034                 IncludeSubgroupMembers => 0,
3035             );
3036
3037             # Limit to UserEquiv groups
3038             my $groups = $Users->NewAlias('Groups');
3039             $Users->Join(
3040                 ALIAS1 => $groups,
3041                 FIELD1 => 'id',
3042                 ALIAS2 => $group_members,
3043                 FIELD2 => 'GroupId'
3044             );
3045             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3046             $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3047
3048
3049             my $display = sub {
3050                 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3051             };
3052             push @map, [
3053                 'Users' => $Users,  # loc_left_pair
3054                 $display => 0
3055             ];
3056         }
3057     }
3058     return @map;
3059 }
3060
3061 =head2 _load_container_object ( $type, $id );
3062
3063 Instantiate container object for saving searches.
3064
3065 =cut
3066
3067 sub _load_container_object {
3068     my ( $obj_type, $obj_id ) = @_;
3069     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3070 }
3071
3072 =head2 _parse_saved_search ( $arg );
3073
3074 Given a serialization string for saved search, and returns the
3075 container object and the search id.
3076
3077 =cut
3078
3079 sub _parse_saved_search {
3080     my $spec = shift;
3081     return unless $spec;
3082     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3083         return;
3084     }
3085     my $obj_type  = $1;
3086     my $obj_id    = $2;
3087     my $search_id = $3;
3088
3089     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3090 }
3091
3092 =head2 ScrubHTML content
3093
3094 Removes unsafe and undesired HTML from the passed content
3095
3096 =cut
3097
3098 my $SCRUBBER;
3099 sub ScrubHTML {
3100     my $Content = shift;
3101     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3102
3103     $Content = '' if !defined($Content);
3104     return $SCRUBBER->scrub($Content);
3105 }
3106
3107 =head2 _NewScrubber
3108
3109 Returns a new L<HTML::Scrubber> object.
3110
3111 If you need to be more lax about what HTML tags and attributes are allowed,
3112 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3113 following:
3114
3115     package HTML::Mason::Commands;
3116     # Let tables through
3117     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3118     1;
3119
3120 =cut
3121
3122 our @SCRUBBER_ALLOWED_TAGS = qw(
3123     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3124     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3125 );
3126
3127 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3128     # Match http, ftp and relative urls
3129     # XXX: we also scrub format strings with this module then allow simple config options
3130     href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3131     face   => 1,
3132     size   => 1,
3133     target => 1,
3134     style  => qr{
3135         ^(?:\s*
3136             (?:(?:background-)?color: \s*
3137                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
3138                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
3139                        [\w\-]+                                  # green, light-blue, etc.
3140                        )                            |
3141                text-align: \s* \w+                  |
3142                font-size: \s* [\w.\-]+              |
3143                font-family: \s* [\w\s"',.\-]+       |
3144                font-weight: \s* [\w\-]+             |
3145
3146                # MS Office styles, which are probably fine.  If we don't, then any
3147                # associated styles in the same attribute get stripped.
3148                mso-[\w\-]+?: \s* [\w\s"',.\-]+
3149             )\s* ;? \s*)
3150          +$ # one or more of these allowed properties from here 'till sunset
3151     }ix,
3152     dir    => qr/^(rtl|ltr)$/i,
3153     lang   => qr/^\w+(-\w+)?$/,
3154 );
3155
3156 our %SCRUBBER_RULES = ();
3157
3158 sub _NewScrubber {
3159     require HTML::Scrubber;
3160     my $scrubber = HTML::Scrubber->new();
3161     $scrubber->default(
3162         0,
3163         {
3164             %SCRUBBER_ALLOWED_ATTRIBUTES,
3165             '*' => 0, # require attributes be explicitly allowed
3166         },
3167     );
3168     $scrubber->deny(qw[*]);
3169     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3170     $scrubber->rules(%SCRUBBER_RULES);
3171
3172     # Scrubbing comments is vital since IE conditional comments can contain
3173     # arbitrary HTML and we'd pass it right on through.
3174     $scrubber->comment(0);
3175
3176     return $scrubber;
3177 }
3178
3179 =head2 JSON
3180
3181 Redispatches to L<RT::Interface::Web/EncodeJSON>
3182
3183 =cut
3184
3185 sub JSON {
3186     RT::Interface::Web::EncodeJSON(@_);
3187 }
3188
3189 package RT::Interface::Web;
3190 RT::Base->_ImportOverlays();
3191
3192 1;