rt/lib/RT/Interface/Web.pm

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