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