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