lib/RT/Interface/Web.pm

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