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     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2076     $message_args->{SquelchMailTo} = \@txn_squelch
2077         if @txn_squelch;
2078
2079     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2080         foreach my $key ( keys %{ $args{ARGSRef} } ) {
2081             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2082
2083             my $var   = ucfirst($1) . 'MessageTo';
2084             my $value = $2;
2085             if ( $message_args->{$var} ) {
2086                 $message_args->{$var} .= ", $value";
2087             } else {
2088                 $message_args->{$var} = $value;
2089             }
2090         }
2091     }
2092 }
2093
2094 sub ProcessAttachments {
2095     my %args = (
2096         ARGSRef => {},
2097         @_
2098     );
2099
2100     my $ARGSRef = $args{ARGSRef} || {};
2101     # deal with deleting uploaded attachments
2102     foreach my $key ( keys %$ARGSRef ) {
2103         if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2104             delete $session{'Attachments'}{$1};
2105         }
2106         $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2107     }
2108
2109     # store the uploaded attachment in session
2110     if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2111     {    # attachment?
2112         my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2113
2114         my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2115         $session{'Attachments'} =
2116           { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2117     }
2118
2119     # delete temporary storage entry to make WebUI clean
2120     unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2121     {
2122         delete $session{'Attachments'};
2123     }
2124 }
2125
2126
2127 =head2 MakeMIMEEntity PARAMHASH
2128
2129 Takes a paramhash Subject, Body and AttachmentFieldName.
2130
2131 Also takes Form, Cc and Type as optional paramhash keys.
2132
2133   Returns a MIME::Entity.
2134
2135 =cut
2136
2137 sub MakeMIMEEntity {
2138
2139     #TODO document what else this takes.
2140     my %args = (
2141         Subject             => undef,
2142         From                => undef,
2143         Cc                  => undef,
2144         Body                => undef,
2145         AttachmentFieldName => undef,
2146         Type                => undef,
2147         Interface           => 'API',
2148         @_,
2149     );
2150     my $Message = MIME::Entity->build(
2151         Type    => 'multipart/mixed',
2152         "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2153         "X-RT-Interface" => $args{Interface},
2154         map { $_ => Encode::encode_utf8( $args{ $_} ) }
2155             grep defined $args{$_}, qw(Subject From Cc)
2156     );
2157
2158     if ( defined $args{'Body'} && length $args{'Body'} ) {
2159
2160         # Make the update content have no 'weird' newlines in it
2161         $args{'Body'} =~ s/\r\n/\n/gs;
2162
2163         $Message->attach(
2164             Type    => $args{'Type'} || 'text/plain',
2165             Charset => 'UTF-8',
2166             Data    => $args{'Body'},
2167         );
2168     }
2169
2170     if ( $args{'AttachmentFieldName'} ) {
2171
2172         my $cgi_object = $m->cgi_object;
2173         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2174         if ( defined $filehandle && length $filehandle ) {
2175
2176             my ( @content, $buffer );
2177             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2178                 push @content, $buffer;
2179             }
2180
2181             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2182
2183             my $filename = "$filehandle";
2184             $filename =~ s{^.*[\\/]}{};
2185
2186             $Message->attach(
2187                 Type     => $uploadinfo->{'Content-Type'},
2188                 Filename => $filename,
2189                 Data     => \@content,
2190             );
2191             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2192                 $Message->head->set( 'Subject' => $filename );
2193             }
2194
2195             # Attachment parts really shouldn't get a Message-ID or "interface"
2196             $Message->head->delete('Message-ID');
2197             $Message->head->delete('X-RT-Interface');
2198         }
2199     }
2200
2201     $Message->make_singlepart;
2202
2203     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2204
2205     return ($Message);
2206
2207 }
2208
2209
2210
2211 =head2 ParseDateToISO
2212
2213 Takes a date in an arbitrary format.
2214 Returns an ISO date and time in GMT
2215
2216 =cut
2217
2218 sub ParseDateToISO {
2219     my $date = shift;
2220
2221     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2222     $date_obj->Set(
2223         Format => 'unknown',
2224         Value  => $date
2225     );
2226     return ( $date_obj->ISO );
2227 }
2228
2229
2230
2231 sub ProcessACLChanges {
2232     my $ARGSref = shift;
2233
2234     my @results;
2235
2236     foreach my $arg ( keys %$ARGSref ) {
2237         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2238
2239         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2240
2241         my @rights;
2242         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2243             @rights = @{ $ARGSref->{$arg} };
2244         } else {
2245             @rights = $ARGSref->{$arg};
2246         }
2247         @rights = grep $_, @rights;
2248         next unless @rights;
2249
2250         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2251         $principal->Load($principal_id);
2252
2253         my $obj;
2254         if ( $object_type eq 'RT::System' ) {
2255             $obj = $RT::System;
2256         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2257             $obj = $object_type->new( $session{'CurrentUser'} );
2258             $obj->Load($object_id);
2259             unless ( $obj->id ) {
2260                 $RT::Logger->error("couldn't load $object_type #$object_id");
2261                 next;
2262             }
2263         } else {
2264             $RT::Logger->error("object type '$object_type' is incorrect");
2265             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2266             next;
2267         }
2268
2269         foreach my $right (@rights) {
2270             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2271             push( @results, $msg );
2272         }
2273     }
2274
2275     return (@results);
2276 }
2277
2278
2279 =head2 ProcessACLs
2280
2281 ProcessACLs expects values from a series of checkboxes that describe the full
2282 set of rights a principal should have on an object.
2283
2284 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2285 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2286 listing the rights the principal should have, and ProcessACLs will modify the
2287 current rights to match.  Additionally, the previously unused CheckACL input
2288 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2289 rights are removed from a principal and as such no SetRights input is
2290 submitted.
2291
2292 =cut
2293
2294 sub ProcessACLs {
2295     my $ARGSref = shift;
2296     my (%state, @results);
2297
2298     my $CheckACL = $ARGSref->{'CheckACL'};
2299     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2300
2301     # Check if we want to grant rights to a previously rights-less user
2302     for my $type (qw(user group)) {
2303         my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2304             or next;
2305
2306         unless ($principal->PrincipalId) {
2307             push @results, loc("Couldn't load the specified principal");
2308             next;
2309         }
2310
2311         my $principal_id = $principal->PrincipalId;
2312
2313         # Turn our addprincipal rights spec into a real one
2314         for my $arg (keys %$ARGSref) {
2315             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2316
2317             my $tuple = "$principal_id-$1";
2318             my $key   = "SetRights-$tuple";
2319
2320             # If we have it already, that's odd, but merge them
2321             if (grep { $_ eq $tuple } @check) {
2322                 $ARGSref->{$key} = [
2323                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2324                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2325                 ];
2326             } else {
2327                 $ARGSref->{$key} = $ARGSref->{$arg};
2328                 push @check, $tuple;
2329             }
2330         }
2331     }
2332
2333     # Build our rights state for each Principal-Object tuple
2334     foreach my $arg ( keys %$ARGSref ) {
2335         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2336
2337         my $tuple  = $1;
2338         my $value  = $ARGSref->{$arg};
2339         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2340         next unless @rights;
2341
2342         $state{$tuple} = { map { $_ => 1 } @rights };
2343     }
2344
2345     foreach my $tuple (List::MoreUtils::uniq @check) {
2346         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2347
2348         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2349
2350         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2351         $principal->Load($principal_id);
2352
2353         my $obj;
2354         if ( $object_type eq 'RT::System' ) {
2355             $obj = $RT::System;
2356         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2357             $obj = $object_type->new( $session{'CurrentUser'} );
2358             $obj->Load($object_id);
2359             unless ( $obj->id ) {
2360                 $RT::Logger->error("couldn't load $object_type #$object_id");
2361                 next;
2362             }
2363         } else {
2364             $RT::Logger->error("object type '$object_type' is incorrect");
2365             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2366             next;
2367         }
2368
2369         my $acls = RT::ACL->new($session{'CurrentUser'});
2370         $acls->LimitToObject( $obj );
2371         $acls->LimitToPrincipal( Id => $principal_id );
2372
2373         while ( my $ace = $acls->Next ) {
2374             my $right = $ace->RightName;
2375
2376             # Has right and should have right
2377             next if delete $state{$tuple}->{$right};
2378
2379             # Has right and shouldn't have right
2380             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2381             push @results, $msg;
2382         }
2383
2384         # For everything left, they don't have the right but they should
2385         for my $right (keys %{ $state{$tuple} || {} }) {
2386             delete $state{$tuple}->{$right};
2387             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2388             push @results, $msg;
2389         }
2390
2391         # Check our state for leftovers
2392         if ( keys %{ $state{$tuple} || {} } ) {
2393             my $missed = join '|', %{$state{$tuple} || {}};
2394             $RT::Logger->warn(
2395                "Uh-oh, it looks like we somehow missed a right in "
2396               ."ProcessACLs.  Here's what was leftover: $missed"
2397             );
2398         }
2399     }
2400
2401     return (@results);
2402 }
2403
2404 =head2 _ParseACLNewPrincipal
2405
2406 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>).  Looks
2407 for the presence of rights being added on a principal of the specified type,
2408 and returns undef if no new principal is being granted rights.  Otherwise loads
2409 up an L<RT::User> or L<RT::Group> object and returns it.  Note that the object
2410 may not be successfully loaded, and you should check C<->id> yourself.
2411
2412 =cut
2413
2414 sub _ParseACLNewPrincipal {
2415     my $ARGSref = shift;
2416     my $type    = lc shift;
2417     my $key     = "AddPrincipalForRights-$type";
2418
2419     return unless $ARGSref->{$key};
2420
2421     my $principal;
2422     if ( $type eq 'user' ) {
2423         $principal = RT::User->new( $session{'CurrentUser'} );
2424         $principal->LoadByCol( Name => $ARGSref->{$key} );
2425     }
2426     elsif ( $type eq 'group' ) {
2427         $principal = RT::Group->new( $session{'CurrentUser'} );
2428         $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2429     }
2430     return $principal;
2431 }
2432
2433
2434 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2435
2436 @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.
2437
2438 Returns an array of success/failure messages
2439
2440 =cut
2441
2442 sub UpdateRecordObject {
2443     my %args = (
2444         ARGSRef         => undef,
2445         AttributesRef   => undef,
2446         Object          => undef,
2447         AttributePrefix => undef,
2448         @_
2449     );
2450
2451     my $Object  = $args{'Object'};
2452     my @results = $Object->Update(
2453         AttributesRef   => $args{'AttributesRef'},
2454         ARGSRef         => $args{'ARGSRef'},
2455         AttributePrefix => $args{'AttributePrefix'},
2456     );
2457
2458     return (@results);
2459 }
2460
2461
2462
2463 sub ProcessCustomFieldUpdates {
2464     my %args = (
2465         CustomFieldObj => undef,
2466         ARGSRef        => undef,
2467         @_
2468     );
2469
2470     my $Object  = $args{'CustomFieldObj'};
2471     my $ARGSRef = $args{'ARGSRef'};
2472
2473     my @attribs = qw(Name Type Description Queue SortOrder);
2474     my @results = UpdateRecordObject(
2475         AttributesRef => \@attribs,
2476         Object        => $Object,
2477         ARGSRef       => $ARGSRef
2478     );
2479
2480     my $prefix = "CustomField-" . $Object->Id;
2481     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2482         my ( $addval, $addmsg ) = $Object->AddValue(
2483             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2484             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2485             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2486         );
2487         push( @results, $addmsg );
2488     }
2489
2490     my @delete_values
2491         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2492         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2493         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2494
2495     foreach my $id (@delete_values) {
2496         next unless defined $id;
2497         my ( $err, $msg ) = $Object->DeleteValue($id);
2498         push( @results, $msg );
2499     }
2500
2501     my $vals = $Object->Values();
2502     while ( my $cfv = $vals->Next() ) {
2503         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2504             if ( $cfv->SortOrder != $so ) {
2505                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2506                 push( @results, $msg );
2507             }
2508         }
2509     }
2510
2511     return (@results);
2512 }
2513
2514
2515
2516 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2517
2518 Returns an array of results messages.
2519
2520 =cut
2521
2522 sub ProcessTicketBasics {
2523
2524     my %args = (
2525         TicketObj => undef,
2526         ARGSRef   => undef,
2527         @_
2528     );
2529
2530     my $TicketObj = $args{'TicketObj'};
2531     my $ARGSRef   = $args{'ARGSRef'};
2532
2533     my $OrigOwner = $TicketObj->Owner;
2534
2535     # Set basic fields
2536     my @attribs = qw(
2537         Subject
2538         FinalPriority
2539         Priority
2540         TimeEstimated
2541         TimeWorked
2542         TimeLeft
2543         Type
2544         Status
2545         Queue
2546     );
2547
2548     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2549     for my $field (qw(Queue Owner)) {
2550         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2551             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2552             my $temp = $class->new(RT->SystemUser);
2553             $temp->Load( $ARGSRef->{$field} );
2554             if ( $temp->id ) {
2555                 $ARGSRef->{$field} = $temp->id;
2556             }
2557         }
2558     }
2559
2560     # Status isn't a field that can be set to a null value.
2561     # RT core complains if you try
2562     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2563
2564     my @results = UpdateRecordObject(
2565         AttributesRef => \@attribs,
2566         Object        => $TicketObj,
2567         ARGSRef       => $ARGSRef,
2568     );
2569
2570     # We special case owner changing, so we can use ForceOwnerChange
2571     if ( $ARGSRef->{'Owner'}
2572       && $ARGSRef->{'Owner'} !~ /\D/
2573       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2574         my ($ChownType);
2575         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2576             $ChownType = "Force";
2577         }
2578         else {
2579             $ChownType = "Set";
2580         }
2581
2582         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2583         push( @results, $msg );
2584     }
2585
2586     # }}}
2587
2588     return (@results);
2589 }
2590
2591 sub ProcessTicketReminders {
2592     my %args = (
2593         TicketObj => undef,
2594         ARGSRef   => undef,
2595         @_
2596     );
2597
2598     my $Ticket = $args{'TicketObj'};
2599     my $args   = $args{'ARGSRef'};
2600     my @results;
2601
2602     my $reminder_collection = $Ticket->Reminders->Collection;
2603
2604     if ( $args->{'update-reminders'} ) {
2605         while ( my $reminder = $reminder_collection->Next ) {
2606             my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2607             if (   $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2608                 $Ticket->Reminders->Resolve($reminder);
2609             }
2610             elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2611                 $Ticket->Reminders->Open($reminder);
2612             }
2613
2614             if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2615                 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2616             }
2617
2618             if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2619                 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2620             }
2621
2622             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2623                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2624                 $DateObj->Set(
2625                     Format => 'unknown',
2626                     Value  => $args->{ 'Reminder-Due-' . $reminder->id }
2627                 );
2628                 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2629                     $reminder->SetDue( $DateObj->ISO );
2630                 }
2631             }
2632         }
2633     }
2634
2635     if ( $args->{'NewReminder-Subject'} ) {
2636         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2637         $due_obj->Set(
2638           Format => 'unknown',
2639           Value => $args->{'NewReminder-Due'}
2640         );
2641         my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2642             Subject => $args->{'NewReminder-Subject'},
2643             Owner   => $args->{'NewReminder-Owner'},
2644             Due     => $due_obj->ISO
2645         );
2646         if ( $add_id ) {
2647             push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2648         }
2649         else {
2650             push @results, $msg;
2651         }
2652     }
2653     return @results;
2654 }
2655
2656 sub ProcessTicketCustomFieldUpdates {
2657     my %args = @_;
2658     $args{'Object'} = delete $args{'TicketObj'};
2659     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2660
2661     # Build up a list of objects that we want to work with
2662     my %custom_fields_to_mod;
2663     foreach my $arg ( keys %$ARGSRef ) {
2664         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2665             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2666         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2667             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2668         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2669             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2670         }
2671     }
2672
2673     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2674 }
2675
2676 sub ProcessObjectCustomFieldUpdates {
2677     my %args    = @_;
2678     my $ARGSRef = $args{'ARGSRef'};
2679     my @results;
2680
2681     # Build up a list of objects that we want to work with
2682     my %custom_fields_to_mod;
2683     foreach my $arg ( keys %$ARGSRef ) {
2684
2685         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2686         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2687
2688         # For each of those objects, find out what custom fields we want to work with.
2689         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2690     }
2691
2692     # For each of those objects
2693     foreach my $class ( keys %custom_fields_to_mod ) {
2694         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2695             my $Object = $args{'Object'};
2696             $Object = $class->new( $session{'CurrentUser'} )
2697                 unless $Object && ref $Object eq $class;
2698
2699             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2700             unless ( $Object->id ) {
2701                 $RT::Logger->warning("Couldn't load object $class #$id");
2702                 next;
2703             }
2704
2705             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2706                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2707                 $CustomFieldObj->SetContextObject($Object);
2708                 $CustomFieldObj->LoadById($cf);
2709                 unless ( $CustomFieldObj->id ) {
2710                     $RT::Logger->warning("Couldn't load custom field #$cf");
2711                     next;
2712                 }
2713                 push @results,
2714                     _ProcessObjectCustomFieldUpdates(
2715                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2716                     Object      => $Object,
2717                     CustomField => $CustomFieldObj,
2718                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2719                     );
2720             }
2721         }
2722     }
2723     return @results;
2724 }
2725
2726 sub _ProcessObjectCustomFieldUpdates {
2727     my %args    = @_;
2728     my $cf      = $args{'CustomField'};
2729     my $cf_type = $cf->Type || '';
2730
2731     # Remove blank Values since the magic field will take care of this. Sometimes
2732     # the browser gives you a blank value which causes CFs to be processed twice
2733     if (   defined $args{'ARGS'}->{'Values'}
2734         && !length $args{'ARGS'}->{'Values'}
2735         && $args{'ARGS'}->{'Values-Magic'} )
2736     {
2737         delete $args{'ARGS'}->{'Values'};
2738     }
2739
2740     my @results;
2741     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2742
2743         # skip category argument
2744         next if $arg eq 'Category';
2745
2746         # and TimeUnits
2747         next if $arg eq 'Value-TimeUnits';
2748
2749         # since http won't pass in a form element with a null value, we need
2750         # to fake it
2751         if ( $arg eq 'Values-Magic' ) {
2752
2753             # We don't care about the magic, if there's really a values element;
2754             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2755             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2756
2757             # "Empty" values does not mean anything for Image and Binary fields
2758             next if $cf_type =~ /^(?:Image|Binary)$/;
2759
2760             $arg = 'Values';
2761             $args{'ARGS'}->{'Values'} = undef;
2762         }
2763
2764         my @values = ();
2765         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2766             @values = @{ $args{'ARGS'}->{$arg} };
2767         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2768             @values = ( $args{'ARGS'}->{$arg} );
2769         } else {
2770             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2771                 if defined $args{'ARGS'}->{$arg};
2772         }
2773         @values = grep length, map {
2774             s/\r+\n/\n/g;
2775             s/^\s+//;
2776             s/\s+$//;
2777             $_;
2778             }
2779             grep defined, @values;
2780
2781         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2782             foreach my $value (@values) {
2783                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2784                     Field => $cf->id,
2785                     Value => $value
2786                 );
2787                 push( @results, $msg );
2788             }
2789         } elsif ( $arg eq 'Upload' ) {
2790             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2791             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2792             push( @results, $msg );
2793         } elsif ( $arg eq 'DeleteValues' ) {
2794             foreach my $value (@values) {
2795                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2796                     Field => $cf,
2797                     Value => $value,
2798                 );
2799                 push( @results, $msg );
2800             }
2801         } elsif ( $arg eq 'DeleteValueIds' ) {
2802             foreach my $value (@values) {
2803                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2804                     Field   => $cf,
2805                     ValueId => $value,
2806                 );
2807                 push( @results, $msg );
2808             }
2809         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2810             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2811
2812             my %values_hash;
2813             foreach my $value (@values) {
2814                 if ( my $entry = $cf_values->HasEntry($value) ) {
2815                     $values_hash{ $entry->id } = 1;
2816                     next;
2817                 }
2818
2819                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2820                     Field => $cf,
2821                     Value => $value
2822                 );
2823                 push( @results, $msg );
2824                 $values_hash{$val} = 1 if $val;
2825             }
2826
2827             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2828             return @results if ( $cf->Type eq 'Date' && ! @values );
2829
2830             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2831             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2832
2833             $cf_values->RedoSearch;
2834             while ( my $cf_value = $cf_values->Next ) {
2835                 next if $values_hash{ $cf_value->id };
2836
2837                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2838                     Field   => $cf,
2839                     ValueId => $cf_value->id
2840                 );
2841                 push( @results, $msg );
2842             }
2843         } elsif ( $arg eq 'Values' ) {
2844             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2845
2846             # keep everything up to the point of difference, delete the rest
2847             my $delete_flag;
2848             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2849                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2850                     shift @values;
2851                     next;
2852                 }
2853
2854                 $delete_flag ||= 1;
2855                 $old_cf->Delete;
2856             }
2857
2858             # now add/replace extra things, if any
2859             foreach my $value (@values) {
2860                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2861                     Field => $cf,
2862                     Value => $value
2863                 );
2864                 push( @results, $msg );
2865             }
2866         } else {
2867             push(
2868                 @results,
2869                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2870                     $cf->Name, ref $args{'Object'},
2871                     $args{'Object'}->id
2872                 )
2873             );
2874         }
2875     }
2876     return @results;
2877 }
2878
2879
2880 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2881
2882 Returns an array of results messages.
2883
2884 =cut
2885
2886 sub ProcessTicketWatchers {
2887     my %args = (
2888         TicketObj => undef,
2889         ARGSRef   => undef,
2890         @_
2891     );
2892     my (@results);
2893
2894     my $Ticket  = $args{'TicketObj'};
2895     my $ARGSRef = $args{'ARGSRef'};
2896
2897     # Munge watchers
2898
2899     foreach my $key ( keys %$ARGSRef ) {
2900
2901         # Delete deletable watchers
2902         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2903             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2904                 PrincipalId => $2,
2905                 Type        => $1
2906             );
2907             push @results, $msg;
2908         }
2909
2910         # Delete watchers in the simple style demanded by the bulk manipulator
2911         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2912             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2913                 Email => $ARGSRef->{$key},
2914                 Type  => $1
2915             );
2916             push @results, $msg;
2917         }
2918
2919         # Add new wathchers by email address
2920         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2921             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2922         {
2923
2924             #They're in this order because otherwise $1 gets clobbered :/
2925             my ( $code, $msg ) = $Ticket->AddWatcher(
2926                 Type  => $ARGSRef->{$key},
2927                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2928             );
2929             push @results, $msg;
2930         }
2931
2932         #Add requestors in the simple style demanded by the bulk manipulator
2933         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2934             my ( $code, $msg ) = $Ticket->AddWatcher(
2935                 Type  => $1,
2936                 Email => $ARGSRef->{$key}
2937             );
2938             push @results, $msg;
2939         }
2940
2941         # Add new  watchers by owner
2942         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2943             my $principal_id = $1;
2944             my $form         = $ARGSRef->{$key};
2945             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2946                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2947
2948                 my ( $code, $msg ) = $Ticket->AddWatcher(
2949                     Type        => $value,
2950                     PrincipalId => $principal_id
2951                 );
2952                 push @results, $msg;
2953             }
2954         }
2955
2956     }
2957     return (@results);
2958 }
2959
2960
2961
2962 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2963
2964 Returns an array of results messages.
2965
2966 =cut
2967
2968 sub ProcessTicketDates {
2969     my %args = (
2970         TicketObj => undef,
2971         ARGSRef   => undef,
2972         @_
2973     );
2974
2975     my $Ticket  = $args{'TicketObj'};
2976     my $ARGSRef = $args{'ARGSRef'};
2977
2978     my (@results);
2979
2980     # Set date fields
2981     my @date_fields = qw(
2982         Told
2983         Resolved
2984         Starts
2985         Started
2986         Due
2987         WillResolve
2988     );
2989
2990     #Run through each field in this list. update the value if apropriate
2991     foreach my $field (@date_fields) {
2992         next unless exists $ARGSRef->{ $field . '_Date' };
2993         next if $ARGSRef->{ $field . '_Date' } eq '';
2994
2995         my ( $code, $msg );
2996
2997         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2998         $DateObj->Set(
2999             Format => 'unknown',
3000             Value  => $ARGSRef->{ $field . '_Date' }
3001         );
3002
3003         my $obj = $field . "Obj";
3004         if (    ( defined $DateObj->Unix )
3005             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3006         {
3007             my $method = "Set$field";
3008             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3009             push @results, "$msg";
3010         }
3011     }
3012
3013     # }}}
3014     return (@results);
3015 }
3016
3017
3018
3019 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3020
3021 Returns an array of results messages.
3022
3023 =cut
3024
3025 sub ProcessTicketLinks {
3026     my %args = (
3027         TicketObj => undef,
3028         ARGSRef   => undef,
3029         @_
3030     );
3031
3032     my $Ticket  = $args{'TicketObj'};
3033     my $ARGSRef = $args{'ARGSRef'};
3034
3035     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3036
3037     #Merge if we need to
3038     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3039         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3040         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3041         push @results, $msg;
3042     }
3043
3044     return (@results);
3045 }
3046
3047
3048 sub ProcessRecordLinks {
3049     my %args = (
3050         RecordObj => undef,
3051         ARGSRef   => undef,
3052         @_
3053     );
3054
3055     my $Record  = $args{'RecordObj'};
3056     my $ARGSRef = $args{'ARGSRef'};
3057
3058     my (@results);
3059
3060     # Delete links that are gone gone gone.
3061     foreach my $arg ( keys %$ARGSRef ) {
3062         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3063             my $base   = $1;
3064             my $type   = $2;
3065             my $target = $3;
3066
3067             my ( $val, $msg ) = $Record->DeleteLink(
3068                 Base   => $base,
3069                 Type   => $type,
3070                 Target => $target
3071             );
3072
3073             push @results, $msg;
3074
3075         }
3076
3077     }
3078
3079     my @linktypes = qw( DependsOn MemberOf RefersTo );
3080
3081     foreach my $linktype (@linktypes) {
3082         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3083             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3084                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3085
3086             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3087                 next unless $luri;
3088                 $luri =~ s/\s+$//;    # Strip trailing whitespace
3089                 my ( $val, $msg ) = $Record->AddLink(
3090                     Target => $luri,
3091                     Type   => $linktype
3092                 );
3093                 push @results, $msg;
3094             }
3095         }
3096         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3097             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3098                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3099
3100             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3101                 next unless $luri;
3102                 my ( $val, $msg ) = $Record->AddLink(
3103                     Base => $luri,
3104                     Type => $linktype
3105                 );
3106
3107                 push @results, $msg;
3108             }
3109         }
3110     }
3111
3112     return (@results);
3113 }
3114
3115 =head2 ProcessTransactionSquelching
3116
3117 Takes a hashref of the submitted form arguments, C<%ARGS>.
3118
3119 Returns a hash of squelched addresses.
3120
3121 =cut
3122
3123 sub ProcessTransactionSquelching {
3124     my $args    = shift;
3125     my %checked = map { $_ => 1 } grep { defined }
3126         (    ref $args->{'TxnSendMailTo'} eq "ARRAY"  ? @{$args->{'TxnSendMailTo'}} :
3127          defined $args->{'TxnSendMailTo'}             ?  ($args->{'TxnSendMailTo'}) :
3128                                                                              () );
3129     my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3130     return %squelched;
3131 }
3132
3133 =head2 _UploadedFile ( $arg );
3134
3135 Takes a CGI parameter name; if a file is uploaded under that name,
3136 return a hash reference suitable for AddCustomFieldValue's use:
3137 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3138
3139 Returns C<undef> if no files were uploaded in the C<$arg> field.
3140
3141 =cut
3142
3143 sub _UploadedFile {
3144     my $arg         = shift;
3145     my $cgi_object  = $m->cgi_object;
3146     my $fh          = $cgi_object->upload($arg) or return undef;
3147     my $upload_info = $cgi_object->uploadInfo($fh);
3148
3149     my $filename = "$fh";
3150     $filename =~ s#^.*[\\/]##;
3151     binmode($fh);
3152
3153     return {
3154         Value        => $filename,
3155         LargeContent => do { local $/; scalar <$fh> },
3156         ContentType  => $upload_info->{'Content-Type'},
3157     };
3158 }
3159
3160 sub GetColumnMapEntry {
3161     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3162
3163     # deal with the simplest thing first
3164     if ( $args{'Map'}{ $args{'Name'} } ) {
3165         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3166     }
3167
3168     # complex things
3169     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3170         return undef unless $args{'Map'}->{$mainkey};
3171         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3172             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3173
3174         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3175     }
3176     return undef;
3177 }
3178
3179 sub ProcessColumnMapValue {
3180     my $value = shift;
3181     my %args = ( Arguments => [], Escape => 1, @_ );
3182
3183     if ( ref $value ) {
3184         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3185             my @tmp = $value->( @{ $args{'Arguments'} } );
3186             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3187         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3188             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3189         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3190             return $$value;
3191         }
3192     }
3193
3194     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3195     return $value;
3196 }
3197
3198 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3199
3200 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3201 principal collections mapped from the categories given.
3202
3203 =cut
3204
3205 sub GetPrincipalsMap {
3206     my $object = shift;
3207     my @map;
3208     for (@_) {
3209         if (/System/) {
3210             my $system = RT::Groups->new($session{'CurrentUser'});
3211             $system->LimitToSystemInternalGroups();
3212             $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3213             push @map, [
3214                 'System' => $system,    # loc_left_pair
3215                 'Type'   => 1,
3216             ];
3217         }
3218         elsif (/Groups/) {
3219             my $groups = RT::Groups->new($session{'CurrentUser'});
3220             $groups->LimitToUserDefinedGroups();
3221             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3222
3223             # Only show groups who have rights granted on this object
3224             $groups->WithGroupRight(
3225                 Right   => '',
3226                 Object  => $object,
3227                 IncludeSystemRights => 0,
3228                 IncludeSubgroupMembers => 0,
3229             );
3230
3231             push @map, [
3232                 'User Groups' => $groups,   # loc_left_pair
3233                 'Name'        => 0
3234             ];
3235         }
3236         elsif (/Roles/) {
3237             my $roles = RT::Groups->new($session{'CurrentUser'});
3238
3239             if ($object->isa('RT::System')) {
3240                 $roles->LimitToRolesForSystem();
3241             }
3242             elsif ($object->isa('RT::Queue')) {
3243                 $roles->LimitToRolesForQueue($object->Id);
3244             }
3245             else {
3246                 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3247                 next;
3248             }
3249             $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3250             push @map, [
3251                 'Roles' => $roles,  # loc_left_pair
3252                 'Type'  => 1
3253             ];
3254         }
3255         elsif (/Users/) {
3256             my $Users = RT->PrivilegedUsers->UserMembersObj();
3257             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3258
3259             # Only show users who have rights granted on this object
3260             my $group_members = $Users->WhoHaveGroupRight(
3261                 Right   => '',
3262                 Object  => $object,
3263                 IncludeSystemRights => 0,
3264                 IncludeSubgroupMembers => 0,
3265             );
3266
3267             # Limit to UserEquiv groups
3268             my $groups = $Users->NewAlias('Groups');
3269             $Users->Join(
3270                 ALIAS1 => $groups,
3271                 FIELD1 => 'id',
3272                 ALIAS2 => $group_members,
3273                 FIELD2 => 'GroupId'
3274             );
3275             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3276             $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3277
3278
3279             my $display = sub {
3280                 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3281             };
3282             push @map, [
3283                 'Users' => $Users,  # loc_left_pair
3284                 $display => 0
3285             ];
3286         }
3287     }
3288     return @map;
3289 }
3290
3291 =head2 _load_container_object ( $type, $id );
3292
3293 Instantiate container object for saving searches.
3294
3295 =cut
3296
3297 sub _load_container_object {
3298     my ( $obj_type, $obj_id ) = @_;
3299     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3300 }
3301
3302 =head2 _parse_saved_search ( $arg );
3303
3304 Given a serialization string for saved search, and returns the
3305 container object and the search id.
3306
3307 =cut
3308
3309 sub _parse_saved_search {
3310     my $spec = shift;
3311     return unless $spec;
3312     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3313         return;
3314     }
3315     my $obj_type  = $1;
3316     my $obj_id    = $2;
3317     my $search_id = $3;
3318
3319     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3320 }
3321
3322 =head2 ScrubHTML content
3323
3324 Removes unsafe and undesired HTML from the passed content
3325
3326 =cut
3327
3328 my $SCRUBBER;
3329 sub ScrubHTML {
3330     my $Content = shift;
3331     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3332
3333     $Content = '' if !defined($Content);
3334     return $SCRUBBER->scrub($Content);
3335 }
3336
3337 =head2 _NewScrubber
3338
3339 Returns a new L<HTML::Scrubber> object.
3340
3341 If you need to be more lax about what HTML tags and attributes are allowed,
3342 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3343 following:
3344
3345     package HTML::Mason::Commands;
3346     # Let tables through
3347     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3348     1;
3349
3350 =cut
3351
3352 our @SCRUBBER_ALLOWED_TAGS = qw(
3353     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3354     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3355 );
3356
3357 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3358     # Match http, https, ftp, mailto and relative urls
3359     # XXX: we also scrub format strings with this module then allow simple config options
3360     href   => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3361     face   => 1,
3362     size   => 1,
3363     target => 1,
3364     style  => qr{
3365         ^(?:\s*
3366             (?:(?:background-)?color: \s*
3367                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
3368                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
3369                        [\w\-]+                                  # green, light-blue, etc.
3370                        )                            |
3371                text-align: \s* \w+                  |
3372                font-size: \s* [\w.\-]+              |
3373                font-family: \s* [\w\s"',.\-]+       |
3374                font-weight: \s* [\w\-]+             |
3375
3376                # MS Office styles, which are probably fine.  If we don't, then any
3377                # associated styles in the same attribute get stripped.
3378                mso-[\w\-]+?: \s* [\w\s"',.\-]+
3379             )\s* ;? \s*)
3380          +$ # one or more of these allowed properties from here 'till sunset
3381     }ix,
3382     dir    => qr/^(rtl|ltr)$/i,
3383     lang   => qr/^\w+(-\w+)?$/,
3384 );
3385
3386 our %SCRUBBER_RULES = ();
3387
3388 sub _NewScrubber {
3389     require HTML::Scrubber;
3390     my $scrubber = HTML::Scrubber->new();
3391     $scrubber->default(
3392         0,
3393         {
3394             %SCRUBBER_ALLOWED_ATTRIBUTES,
3395             '*' => 0, # require attributes be explicitly allowed
3396         },
3397     );
3398     $scrubber->deny(qw[*]);
3399     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3400     $scrubber->rules(%SCRUBBER_RULES);
3401
3402     # Scrubbing comments is vital since IE conditional comments can contain
3403     # arbitrary HTML and we'd pass it right on through.
3404     $scrubber->comment(0);
3405
3406     return $scrubber;
3407 }
3408
3409 =head2 JSON
3410
3411 Redispatches to L<RT::Interface::Web/EncodeJSON>
3412
3413 =cut
3414
3415 sub JSON {
3416     RT::Interface::Web::EncodeJSON(@_);
3417 }
3418
3419 package RT::Interface::Web;
3420 RT::Base->_ImportOverlays();
3421
3422 1;