rt/lib/RT/Interface/Web.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2014 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 chart) or bookmark a result page.
1287     '/Search/Results.html' => 1,
1288     '/Search/Simple.html'  => 1,
1289     '/m/tickets/search'    => 1,
1290     '/Search/Chart.html'   => 1,
1291
1292     # This page takes Attachment and Transaction argument to figure
1293     # out what to show, but it's read only and will deny information if you
1294     # don't have ShowOutgoingEmail.
1295     '/Ticket/ShowEmailRecord.html' => 1,
1296 );
1297
1298 # Components which are blacklisted from automatic, argument-based whitelisting.
1299 # These pages are not idempotent when called with just an id.
1300 our %is_blacklisted_component = (
1301     # Takes only id and toggles bookmark state
1302     '/Helpers/Toggle/TicketBookmark' => 1,
1303 );
1304
1305 sub IsCompCSRFWhitelisted {
1306     my $comp = shift;
1307     my $ARGS = shift;
1308
1309     return 1 if $is_whitelisted_component{$comp};
1310
1311     my %args = %{ $ARGS };
1312
1313     # If the user specifies a *correct* user and pass then they are
1314     # golden.  This acts on the presumption that external forms may
1315     # hardcode a username and password -- if a malicious attacker knew
1316     # both already, CSRF is the least of your problems.
1317     my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1318     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1319         my $user_obj = RT::CurrentUser->new();
1320         $user_obj->Load($args{user});
1321         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1322
1323         delete $args{user};
1324         delete $args{pass};
1325     }
1326
1327     # Some pages aren't idempotent even with safe args like id; blacklist
1328     # them from the automatic whitelisting below.
1329     return 0 if $is_blacklisted_component{$comp};
1330
1331     # Eliminate arguments that do not indicate an effectful request.
1332     # For example, "id" is acceptable because that is how RT retrieves a
1333     # record.
1334     delete $args{id};
1335
1336     # If they have a results= from MaybeRedirectForResults, that's also fine.
1337     delete $args{results};
1338
1339     # The homepage refresh, which uses the Refresh header, doesn't send
1340     # a referer in most browsers; whitelist the one parameter it reloads
1341     # with, HomeRefreshInterval, which is safe
1342     delete $args{HomeRefreshInterval};
1343
1344     # The NotMobile flag is fine for any page; it's only used to toggle a flag
1345     # in the session related to which interface you get.
1346     delete $args{NotMobile};
1347
1348     # If there are no arguments, then it's likely to be an idempotent
1349     # request, which are not susceptible to CSRF
1350     return 1 if !%args;
1351
1352     return 0;
1353 }
1354
1355 sub IsRefererCSRFWhitelisted {
1356     my $referer = _NormalizeHost(shift);
1357     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1358     $base_url = $base_url->host_port;
1359
1360     my $configs;
1361     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1362         push @$configs,$config;
1363
1364         my $host_port = $referer->host_port;
1365         if ($config =~ /\*/) {
1366             # Turn a literal * into a domain component or partial component match.
1367             # Refer to http://tools.ietf.org/html/rfc2818#page-5
1368             my $regex = join "[a-zA-Z0-9\-]*",
1369                          map { quotemeta($_) }
1370                        split /\*/, $config;
1371
1372             return 1 if $host_port =~ /^$regex$/i;
1373         } else {
1374             return 1 if $host_port eq $config;
1375         }
1376     }
1377
1378     return (0,$referer,$configs);
1379 }
1380
1381 =head3 _NormalizeHost
1382
1383 Takes a URI and creates a URI object that's been normalized
1384 to handle common problems such as localhost vs 127.0.0.1
1385
1386 =cut
1387
1388 sub _NormalizeHost {
1389     my $s = shift;
1390     $s = "http://$s" unless $s =~ /^http/i;
1391     my $uri= URI->new($s);
1392     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1393
1394     return $uri;
1395
1396 }
1397
1398 sub IsPossibleCSRF {
1399     my $ARGS = shift;
1400
1401     # If first request on this session is to a REST endpoint, then
1402     # whitelist the REST endpoints -- and explicitly deny non-REST
1403     # endpoints.  We do this because using a REST cookie in a browser
1404     # would open the user to CSRF attacks to the REST endpoints.
1405     my $path = $HTML::Mason::Commands::r->path_info;
1406     $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1407         unless defined $HTML::Mason::Commands::session{'REST'};
1408
1409     if ($HTML::Mason::Commands::session{'REST'}) {
1410         return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1411         my $why = <<EOT;
1412 This login session belongs to a REST client, and cannot be used to
1413 access non-REST interfaces of RT for security reasons.
1414 EOT
1415         my $details = <<EOT;
1416 Please log out and back in to obtain a session for normal browsing.  If
1417 you understand the security implications, disabling RT's CSRF protection
1418 will remove this restriction.
1419 EOT
1420         chomp $details;
1421         HTML::Mason::Commands::Abort( $why, Details => $details );
1422     }
1423
1424     return 0 if IsCompCSRFWhitelisted(
1425         $HTML::Mason::Commands::m->request_comp->path,
1426         $ARGS
1427     );
1428
1429     # if there is no Referer header then assume the worst
1430     return (1,
1431             "your browser did not supply a Referrer header", # loc
1432         ) if !$ENV{HTTP_REFERER};
1433
1434     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1435     return 0 if $whitelisted;
1436
1437     if ( @$configs > 1 ) {
1438         return (1,
1439                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1440                 $browser->host_port,
1441                 shift @$configs,
1442                 join(', ', @$configs) );
1443     }
1444
1445     return (1,
1446             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1447             $browser->host_port,
1448             $configs->[0]);
1449 }
1450
1451 sub ExpandCSRFToken {
1452     my $ARGS = shift;
1453
1454     my $token = delete $ARGS->{CSRF_Token};
1455     return unless $token;
1456
1457     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1458     return unless $data;
1459     return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1460
1461     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1462     return unless $user->ValidateAuthString( $data->{auth}, $token );
1463
1464     %{$ARGS} = %{$data->{args}};
1465     $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1466
1467     # We explicitly stored file attachments with the request, but not in
1468     # the session yet, as that would itself be an attack.  Put them into
1469     # the session now, so they'll be visible.
1470     if ($data->{attach}) {
1471         my $filename = $data->{attach}{filename};
1472         my $mime     = $data->{attach}{mime};
1473         $HTML::Mason::Commands::session{'Attachments'}{$filename}
1474             = $mime;
1475     }
1476
1477     return 1;
1478 }
1479
1480 sub StoreRequestToken {
1481     my $ARGS = shift;
1482
1483     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1484     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1485     my $data = {
1486         auth => $user->GenerateAuthString( $token ),
1487         path => $HTML::Mason::Commands::r->path_info,
1488         args => $ARGS,
1489     };
1490     if ($ARGS->{Attach}) {
1491         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1492         my $file_path = delete $ARGS->{'Attach'};
1493         $data->{attach} = {
1494             filename => Encode::decode_utf8("$file_path"),
1495             mime     => $attachment,
1496         };
1497     }
1498
1499     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1500     $HTML::Mason::Commands::session{'i'}++;
1501     return $token;
1502 }
1503
1504 sub MaybeShowInterstitialCSRFPage {
1505     my $ARGS = shift;
1506
1507     return unless RT->Config->Get('RestrictReferrer');
1508
1509     # Deal with the form token provided by the interstitial, which lets
1510     # browsers which never set referer headers still use RT, if
1511     # painfully.  This blows values into ARGS
1512     return if ExpandCSRFToken($ARGS);
1513
1514     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1515     return if !$is_csrf;
1516
1517     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1518
1519     my $token = StoreRequestToken($ARGS);
1520     $HTML::Mason::Commands::m->comp(
1521         '/Elements/CSRF',
1522         OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1523         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1524         Token => $token,
1525     );
1526     # Calls abort, never gets here
1527 }
1528
1529 our @POTENTIAL_PAGE_ACTIONS = (
1530     qr'/Ticket/Create.html' => "create a ticket",              # loc
1531     qr'/Ticket/'            => "update a ticket",              # loc
1532     qr'/Admin/'             => "modify RT's configuration",    # loc
1533     qr'/Approval/'          => "update an approval",           # loc
1534     qr'/Articles/'          => "update an article",            # loc
1535     qr'/Dashboards/'        => "modify a dashboard",           # loc
1536     qr'/m/ticket/'          => "update a ticket",              # loc
1537     qr'Prefs'               => "modify your preferences",      # loc
1538     qr'/Search/'            => "modify or access a search",    # loc
1539     qr'/SelfService/Create' => "create a ticket",              # loc
1540     qr'/SelfService/'       => "update a ticket",              # loc
1541 );
1542
1543 sub PotentialPageAction {
1544     my $page = shift;
1545     my @potentials = @POTENTIAL_PAGE_ACTIONS;
1546     while (my ($pattern, $result) = splice @potentials, 0, 2) {
1547         return HTML::Mason::Commands::loc($result)
1548             if $page =~ $pattern;
1549     }
1550     return "";
1551 }
1552
1553 package HTML::Mason::Commands;
1554
1555 use vars qw/$r $m %session/;
1556
1557 sub Menu {
1558     return $HTML::Mason::Commands::m->notes('menu');
1559 }
1560
1561 sub PageMenu {
1562     return $HTML::Mason::Commands::m->notes('page-menu');
1563 }
1564
1565 sub PageWidgets {
1566     return $HTML::Mason::Commands::m->notes('page-widgets');
1567 }
1568
1569
1570
1571 =head2 loc ARRAY
1572
1573 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1574 with whatever it's called with. If there is no $session{'CurrentUser'},
1575 it creates a temporary user, so we have something to get a localisation handle
1576 through
1577
1578 =cut
1579
1580 sub loc {
1581
1582     if ( $session{'CurrentUser'}
1583         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1584     {
1585         return ( $session{'CurrentUser'}->loc(@_) );
1586     } elsif (
1587         my $u = eval {
1588             RT::CurrentUser->new();
1589         }
1590         )
1591     {
1592         return ( $u->loc(@_) );
1593     } else {
1594
1595         # pathetic case -- SystemUser is gone.
1596         return $_[0];
1597     }
1598 }
1599
1600
1601
1602 =head2 loc_fuzzy STRING
1603
1604 loc_fuzzy is for handling localizations of messages that may already
1605 contain interpolated variables, typically returned from libraries
1606 outside RT's control.  It takes the message string and extracts the
1607 variable array automatically by matching against the candidate entries
1608 inside the lexicon file.
1609
1610 =cut
1611
1612 sub loc_fuzzy {
1613     my $msg = shift;
1614
1615     if ( $session{'CurrentUser'}
1616         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1617     {
1618         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1619     } else {
1620         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1621         return ( $u->loc_fuzzy($msg) );
1622     }
1623 }
1624
1625
1626 # Error - calls Error and aborts
1627 sub Abort {
1628     my $why  = shift;
1629     my %args = @_;
1630
1631     if (   $session{'ErrorDocument'}
1632         && $session{'ErrorDocumentType'} )
1633     {
1634         $r->content_type( $session{'ErrorDocumentType'} );
1635         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1636         $m->abort;
1637     } else {
1638         $m->comp( "/Elements/Error", Why => $why, %args );
1639         $m->abort;
1640     }
1641 }
1642
1643 sub MaybeRedirectForResults {
1644     my %args = (
1645         Path      => $HTML::Mason::Commands::m->request_comp->path,
1646         Arguments => {},
1647         Anchor    => undef,
1648         Actions   => undef,
1649         Force     => 0,
1650         @_
1651     );
1652     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1653     return unless $has_actions || $args{'Force'};
1654
1655     my %arguments = %{ $args{'Arguments'} };
1656
1657     if ( $has_actions ) {
1658         my $key = Digest::MD5::md5_hex( rand(1024) );
1659         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1660         $session{'i'}++;
1661         $arguments{'results'} = $key;
1662     }
1663
1664     $args{'Path'} =~ s!^/+!!;
1665     my $url = RT->Config->Get('WebURL') . $args{Path};
1666
1667     if ( keys %arguments ) {
1668         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1669     }
1670     if ( $args{'Anchor'} ) {
1671         $url .= "#". $args{'Anchor'};
1672     }
1673     return RT::Interface::Web::Redirect($url);
1674 }
1675
1676 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1677
1678 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1679 redirect to the approvals display page, preserving any arguments.
1680
1681 C<Path>s matching C<Whitelist> are let through.
1682
1683 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1684
1685 =cut
1686
1687 sub MaybeRedirectToApproval {
1688     my %args = (
1689         Path        => $HTML::Mason::Commands::m->request_comp->path,
1690         ARGSRef     => {},
1691         Whitelist   => undef,
1692         @_
1693     );
1694
1695     return unless $ENV{REQUEST_METHOD} eq 'GET';
1696
1697     my $id = $args{ARGSRef}->{id};
1698
1699     if (    $id
1700         and RT->Config->Get('ForceApprovalsView')
1701         and not $args{Path} =~ /$args{Whitelist}/)
1702     {
1703         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1704         $ticket->Load($id);
1705
1706         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1707             MaybeRedirectForResults(
1708                 Path      => "/Approvals/Display.html",
1709                 Force     => 1,
1710                 Anchor    => $args{ARGSRef}->{Anchor},
1711                 Arguments => $args{ARGSRef},
1712             );
1713         }
1714     }
1715 }
1716
1717 =head2 CreateTicket ARGS
1718
1719 Create a new ticket, using Mason's %ARGS.  returns @results.
1720
1721 =cut
1722
1723 sub CreateTicket {
1724     my %ARGS = (@_);
1725
1726     my (@Actions);
1727
1728     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1729
1730     my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1731     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1732         Abort('Queue not found');
1733     }
1734
1735     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1736         Abort('You have no permission to create tickets in that queue.');
1737     }
1738
1739     my $due;
1740     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1741         $due = RT::Date->new( $session{'CurrentUser'} );
1742         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1743     }
1744     my $starts;
1745     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1746         $starts = RT::Date->new( $session{'CurrentUser'} );
1747         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1748     }
1749
1750     my $sigless = RT::Interface::Web::StripContent(
1751         Content        => $ARGS{Content},
1752         ContentType    => $ARGS{ContentType},
1753         StripSignature => 1,
1754         CurrentUser    => $session{'CurrentUser'},
1755     );
1756
1757     my $MIMEObj = MakeMIMEEntity(
1758         Subject => $ARGS{'Subject'},
1759         From    => $ARGS{'From'},
1760         Cc      => $ARGS{'Cc'},
1761         Body    => $sigless,
1762         Type    => $ARGS{'ContentType'},
1763         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1764     );
1765
1766     if ( $ARGS{'Attachments'} ) {
1767         my $rv = $MIMEObj->make_multipart;
1768         $RT::Logger->error("Couldn't make multipart message")
1769             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1770
1771         foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
1772             unless ($_) {
1773                 $RT::Logger->error("Couldn't add empty attachemnt");
1774                 next;
1775             }
1776             $MIMEObj->add_part($_);
1777         }
1778     }
1779
1780     for my $argument (qw(Encrypt Sign)) {
1781         $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1782     }
1783
1784     my %create_args = (
1785         Type => $ARGS{'Type'} || 'ticket',
1786         Queue => $ARGS{'Queue'},
1787         Owner => $ARGS{'Owner'},
1788
1789         # note: name change
1790         Requestor       => $ARGS{'Requestors'},
1791         Cc              => $ARGS{'Cc'},
1792         AdminCc         => $ARGS{'AdminCc'},
1793         InitialPriority => $ARGS{'InitialPriority'},
1794         FinalPriority   => $ARGS{'FinalPriority'},
1795         TimeLeft        => $ARGS{'TimeLeft'},
1796         TimeEstimated   => $ARGS{'TimeEstimated'},
1797         TimeWorked      => $ARGS{'TimeWorked'},
1798         Subject         => $ARGS{'Subject'},
1799         Status          => $ARGS{'Status'},
1800         Due             => $due ? $due->ISO : undef,
1801         Starts          => $starts ? $starts->ISO : undef,
1802         MIMEObj         => $MIMEObj
1803     );
1804
1805     my @txn_squelch;
1806     foreach my $type (qw(Requestor Cc AdminCc)) {
1807         push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1808             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1809     }
1810     $create_args{TransSquelchMailTo} = \@txn_squelch
1811         if @txn_squelch;
1812
1813     if ( $ARGS{'AttachTickets'} ) {
1814         require RT::Action::SendEmail;
1815         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1816             ref $ARGS{'AttachTickets'}
1817             ? @{ $ARGS{'AttachTickets'} }
1818             : ( $ARGS{'AttachTickets'} ) );
1819     }
1820
1821     foreach my $arg ( keys %ARGS ) {
1822         next if $arg =~ /-(?:Magic|Category)$/;
1823
1824         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1825             $create_args{$arg} = $ARGS{$arg};
1826         }
1827
1828         # Object-RT::Ticket--CustomField-3-Values
1829         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1830             my $cfid = $1;
1831
1832             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1833             $cf->SetContextObject( $Queue );
1834             $cf->Load($cfid);
1835             unless ( $cf->id ) {
1836                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1837                 next;
1838             }
1839
1840             if ( $arg =~ /-Upload$/ ) {
1841                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1842                 next;
1843             }
1844
1845             my $type = $cf->Type;
1846
1847             my @values = ();
1848             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1849                 @values = @{ $ARGS{$arg} };
1850             } elsif ( $type =~ /text/i ) {
1851                 @values = ( $ARGS{$arg} );
1852             } else {
1853                 no warnings 'uninitialized';
1854                 @values = split /\r*\n/, $ARGS{$arg};
1855             }
1856             @values = grep length, map {
1857                 s/\r+\n/\n/g;
1858                 s/^\s+//;
1859                 s/\s+$//;
1860                 $_;
1861                 }
1862                 grep defined, @values;
1863
1864             $create_args{"CustomField-$cfid"} = \@values;
1865         }
1866     }
1867
1868     # turn new link lists into arrays, and pass in the proper arguments
1869     my %map = (
1870         'new-DependsOn' => 'DependsOn',
1871         'DependsOn-new' => 'DependedOnBy',
1872         'new-MemberOf'  => 'Parents',
1873         'MemberOf-new'  => 'Children',
1874         'new-RefersTo'  => 'RefersTo',
1875         'RefersTo-new'  => 'ReferredToBy',
1876     );
1877     foreach my $key ( keys %map ) {
1878         next unless $ARGS{$key};
1879         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1880
1881     }
1882
1883     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1884     unless ($id) {
1885         Abort($ErrMsg);
1886     }
1887
1888     push( @Actions, split( "\n", $ErrMsg ) );
1889     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1890         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1891     }
1892     return ( $Ticket, @Actions );
1893
1894 }
1895
1896
1897
1898 =head2  LoadTicket id
1899
1900 Takes a ticket id as its only variable. if it's handed an array, it takes
1901 the first value.
1902
1903 Returns an RT::Ticket object as the current user.
1904
1905 =cut
1906
1907 sub LoadTicket {
1908     my $id = shift;
1909
1910     if ( ref($id) eq "ARRAY" ) {
1911         $id = $id->[0];
1912     }
1913
1914     unless ($id) {
1915         Abort("No ticket specified");
1916     }
1917
1918     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1919     $Ticket->Load($id);
1920     unless ( $Ticket->id ) {
1921         Abort("Could not load ticket $id");
1922     }
1923     return $Ticket;
1924 }
1925
1926
1927
1928 =head2 ProcessUpdateMessage
1929
1930 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1931
1932 Don't write message if it only contains current user's signature and
1933 SkipSignatureOnly argument is true. Function anyway adds attachments
1934 and updates time worked field even if skips message. The default value
1935 is true.
1936
1937 =cut
1938
1939 # change from stock: if txn custom fields are set but there's no content
1940 # or attachment, create a Touch txn instead of doing nothing
1941
1942 sub ProcessUpdateMessage {
1943
1944     my %args = (
1945         ARGSRef           => undef,
1946         TicketObj         => undef,
1947         SkipSignatureOnly => 1,
1948         @_
1949     );
1950
1951     if ( $args{ARGSRef}->{'UpdateAttachments'}
1952         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1953     {
1954         delete $args{ARGSRef}->{'UpdateAttachments'};
1955     }
1956
1957     # Strip the signature
1958     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1959         Content        => $args{ARGSRef}->{UpdateContent},
1960         ContentType    => $args{ARGSRef}->{UpdateContentType},
1961         StripSignature => $args{SkipSignatureOnly},
1962         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1963     );
1964
1965     my %txn_customfields;
1966
1967     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1968       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1969         next if $key =~ /(TimeUnits|Magic)$/;
1970         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1971       }
1972     }
1973
1974     # If, after stripping the signature, we have no message, create a
1975     # Touch transaction if necessary
1976     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1977         and not length $args{ARGSRef}->{'UpdateContent'} )
1978     {
1979         #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1980         #      $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1981         #          delete $args{ARGSRef}->{'UpdateTimeWorked'};
1982         #  }
1983
1984         my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1985         if ( $timetaken or grep {length $_} values %txn_customfields ) {
1986             my ( $Transaction, $Description, $Object ) =
1987                 $args{TicketObj}->Touch(
1988                   CustomFields => \%txn_customfields,
1989                   TimeTaken => $timetaken
1990                 );
1991             return $Description;
1992         }
1993         return;
1994     }
1995
1996     if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1997         $args{ARGSRef}->{'UpdateSubject'} = undef;
1998     }
1999
2000     my $Message = MakeMIMEEntity(
2001         Subject => $args{ARGSRef}->{'UpdateSubject'},
2002         Body    => $args{ARGSRef}->{'UpdateContent'},
2003         Type    => $args{ARGSRef}->{'UpdateContentType'},
2004         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2005     );
2006
2007     $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
2008         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2009     ) );
2010     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2011     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2012         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2013     } else {
2014         $old_txn = $args{TicketObj}->Transactions->First();
2015     }
2016
2017     if ( my $msg = $old_txn->Message->First ) {
2018         RT::Interface::Email::SetInReplyTo(
2019             Message   => $Message,
2020             InReplyTo => $msg
2021         );
2022     }
2023
2024     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2025         $Message->make_multipart;
2026         $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
2027                                   sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2028     }
2029
2030     if ( $args{ARGSRef}->{'AttachTickets'} ) {
2031         require RT::Action::SendEmail;
2032         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2033             ref $args{ARGSRef}->{'AttachTickets'}
2034             ? @{ $args{ARGSRef}->{'AttachTickets'} }
2035             : ( $args{ARGSRef}->{'AttachTickets'} ) );
2036     }
2037
2038     my %message_args = (
2039         Sign         => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2040         Encrypt      => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2041         MIMEObj      => $Message,
2042         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
2043         CustomFields => \%txn_customfields,
2044     );
2045
2046     _ProcessUpdateMessageRecipients(
2047         MessageArgs => \%message_args,
2048         %args,
2049     );
2050
2051     my @results;
2052     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2053         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2054         push( @results, $Description );
2055         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2056     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2057         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2058         push( @results, $Description );
2059         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2060     } else {
2061         push( @results,
2062             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2063     }
2064     return @results;
2065 }
2066
2067 sub _ProcessUpdateMessageRecipients {
2068     my %args = (
2069         ARGSRef           => undef,
2070         TicketObj         => undef,
2071         MessageArgs       => undef,
2072         @_,
2073     );
2074
2075     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2076     my $cc  = $args{ARGSRef}->{'UpdateCc'};
2077
2078     my $message_args = $args{MessageArgs};
2079
2080     $message_args->{CcMessageTo} = $cc;
2081     $message_args->{BccMessageTo} = $bcc;
2082
2083     my @txn_squelch;
2084     foreach my $type (qw(Cc AdminCc)) {
2085         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2086             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2087             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2088             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2089         }
2090     }
2091     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2092         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2093         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2094     }
2095
2096     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2097     $message_args->{SquelchMailTo} = \@txn_squelch
2098         if @txn_squelch;
2099
2100     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2101         foreach my $key ( keys %{ $args{ARGSRef} } ) {
2102             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2103
2104             my $var   = ucfirst($1) . 'MessageTo';
2105             my $value = $2;
2106             if ( $message_args->{$var} ) {
2107                 $message_args->{$var} .= ", $value";
2108             } else {
2109                 $message_args->{$var} = $value;
2110             }
2111         }
2112     }
2113 }
2114
2115 sub ProcessAttachments {
2116     my %args = (
2117         ARGSRef => {},
2118         @_
2119     );
2120
2121     my $ARGSRef = $args{ARGSRef} || {};
2122     # deal with deleting uploaded attachments
2123     foreach my $key ( keys %$ARGSRef ) {
2124         if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2125             delete $session{'Attachments'}{$1};
2126         }
2127         $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2128     }
2129
2130     # store the uploaded attachment in session
2131     if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2132     {    # attachment?
2133         my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2134
2135         my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2136         $session{'Attachments'} =
2137           { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2138     }
2139
2140     # delete temporary storage entry to make WebUI clean
2141     unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2142     {
2143         delete $session{'Attachments'};
2144     }
2145 }
2146
2147
2148 =head2 MakeMIMEEntity PARAMHASH
2149
2150 Takes a paramhash Subject, Body and AttachmentFieldName.
2151
2152 Also takes Form, Cc and Type as optional paramhash keys.
2153
2154   Returns a MIME::Entity.
2155
2156 =cut
2157
2158 sub MakeMIMEEntity {
2159
2160     #TODO document what else this takes.
2161     my %args = (
2162         Subject             => undef,
2163         From                => undef,
2164         Cc                  => undef,
2165         Body                => undef,
2166         AttachmentFieldName => undef,
2167         Type                => undef,
2168         Interface           => 'API',
2169         @_,
2170     );
2171     my $Message = MIME::Entity->build(
2172         Type    => 'multipart/mixed',
2173         "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2174         "X-RT-Interface" => $args{Interface},
2175         map { $_ => Encode::encode_utf8( $args{ $_} ) }
2176             grep defined $args{$_}, qw(Subject From Cc)
2177     );
2178
2179     if ( defined $args{'Body'} && length $args{'Body'} ) {
2180
2181         # Make the update content have no 'weird' newlines in it
2182         $args{'Body'} =~ s/\r\n/\n/gs;
2183
2184         $Message->attach(
2185             Type    => $args{'Type'} || 'text/plain',
2186             Charset => 'UTF-8',
2187             Data    => $args{'Body'},
2188         );
2189     }
2190
2191     if ( $args{'AttachmentFieldName'} ) {
2192
2193         my $cgi_object = $m->cgi_object;
2194         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2195         if ( defined $filehandle && length $filehandle ) {
2196
2197             my ( @content, $buffer );
2198             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2199                 push @content, $buffer;
2200             }
2201
2202             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2203
2204             my $filename = "$filehandle";
2205             $filename =~ s{^.*[\\/]}{};
2206
2207             $Message->attach(
2208                 Type     => $uploadinfo->{'Content-Type'},
2209                 Filename => $filename,
2210                 Data     => \@content,
2211             );
2212             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2213                 $Message->head->set( 'Subject' => $filename );
2214             }
2215
2216             # Attachment parts really shouldn't get a Message-ID or "interface"
2217             $Message->head->delete('Message-ID');
2218             $Message->head->delete('X-RT-Interface');
2219         }
2220     }
2221
2222     $Message->make_singlepart;
2223
2224     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2225
2226     return ($Message);
2227
2228 }
2229
2230
2231
2232 =head2 ParseDateToISO
2233
2234 Takes a date in an arbitrary format.
2235 Returns an ISO date and time in GMT
2236
2237 =cut
2238
2239 sub ParseDateToISO {
2240     my $date = shift;
2241
2242     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2243     $date_obj->Set(
2244         Format => 'unknown',
2245         Value  => $date
2246     );
2247     return ( $date_obj->ISO );
2248 }
2249
2250
2251
2252 sub ProcessACLChanges {
2253     my $ARGSref = shift;
2254
2255     my @results;
2256
2257     foreach my $arg ( keys %$ARGSref ) {
2258         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2259
2260         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2261
2262         my @rights;
2263         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2264             @rights = @{ $ARGSref->{$arg} };
2265         } else {
2266             @rights = $ARGSref->{$arg};
2267         }
2268         @rights = grep $_, @rights;
2269         next unless @rights;
2270
2271         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2272         $principal->Load($principal_id);
2273
2274         my $obj;
2275         if ( $object_type eq 'RT::System' ) {
2276             $obj = $RT::System;
2277         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2278             $obj = $object_type->new( $session{'CurrentUser'} );
2279             $obj->Load($object_id);
2280             unless ( $obj->id ) {
2281                 $RT::Logger->error("couldn't load $object_type #$object_id");
2282                 next;
2283             }
2284         } else {
2285             $RT::Logger->error("object type '$object_type' is incorrect");
2286             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2287             next;
2288         }
2289
2290         foreach my $right (@rights) {
2291             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2292             push( @results, $msg );
2293         }
2294     }
2295
2296     return (@results);
2297 }
2298
2299
2300 =head2 ProcessACLs
2301
2302 ProcessACLs expects values from a series of checkboxes that describe the full
2303 set of rights a principal should have on an object.
2304
2305 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2306 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2307 listing the rights the principal should have, and ProcessACLs will modify the
2308 current rights to match.  Additionally, the previously unused CheckACL input
2309 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2310 rights are removed from a principal and as such no SetRights input is
2311 submitted.
2312
2313 =cut
2314
2315 sub ProcessACLs {
2316     my $ARGSref = shift;
2317     my (%state, @results);
2318
2319     my $CheckACL = $ARGSref->{'CheckACL'};
2320     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2321
2322     # Check if we want to grant rights to a previously rights-less user
2323     for my $type (qw(user group)) {
2324         my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2325             or next;
2326
2327         unless ($principal->PrincipalId) {
2328             push @results, loc("Couldn't load the specified principal");
2329             next;
2330         }
2331
2332         my $principal_id = $principal->PrincipalId;
2333
2334         # Turn our addprincipal rights spec into a real one
2335         for my $arg (keys %$ARGSref) {
2336             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2337
2338             my $tuple = "$principal_id-$1";
2339             my $key   = "SetRights-$tuple";
2340
2341             # If we have it already, that's odd, but merge them
2342             if (grep { $_ eq $tuple } @check) {
2343                 $ARGSref->{$key} = [
2344                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2345                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2346                 ];
2347             } else {
2348                 $ARGSref->{$key} = $ARGSref->{$arg};
2349                 push @check, $tuple;
2350             }
2351         }
2352     }
2353
2354     # Build our rights state for each Principal-Object tuple
2355     foreach my $arg ( keys %$ARGSref ) {
2356         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2357
2358         my $tuple  = $1;
2359         my $value  = $ARGSref->{$arg};
2360         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2361         next unless @rights;
2362
2363         $state{$tuple} = { map { $_ => 1 } @rights };
2364     }
2365
2366     foreach my $tuple (List::MoreUtils::uniq @check) {
2367         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2368
2369         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2370
2371         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2372         $principal->Load($principal_id);
2373
2374         my $obj;
2375         if ( $object_type eq 'RT::System' ) {
2376             $obj = $RT::System;
2377         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2378             $obj = $object_type->new( $session{'CurrentUser'} );
2379             $obj->Load($object_id);
2380             unless ( $obj->id ) {
2381                 $RT::Logger->error("couldn't load $object_type #$object_id");
2382                 next;
2383             }
2384         } else {
2385             $RT::Logger->error("object type '$object_type' is incorrect");
2386             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2387             next;
2388         }
2389
2390         my $acls = RT::ACL->new($session{'CurrentUser'});
2391         $acls->LimitToObject( $obj );
2392         $acls->LimitToPrincipal( Id => $principal_id );
2393
2394         while ( my $ace = $acls->Next ) {
2395             my $right = $ace->RightName;
2396
2397             # Has right and should have right
2398             next if delete $state{$tuple}->{$right};
2399
2400             # Has right and shouldn't have right
2401             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2402             push @results, $msg;
2403         }
2404
2405         # For everything left, they don't have the right but they should
2406         for my $right (keys %{ $state{$tuple} || {} }) {
2407             delete $state{$tuple}->{$right};
2408             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2409             push @results, $msg;
2410         }
2411
2412         # Check our state for leftovers
2413         if ( keys %{ $state{$tuple} || {} } ) {
2414             my $missed = join '|', %{$state{$tuple} || {}};
2415             $RT::Logger->warn(
2416                "Uh-oh, it looks like we somehow missed a right in "
2417               ."ProcessACLs.  Here's what was leftover: $missed"
2418             );
2419         }
2420     }
2421
2422     return (@results);
2423 }
2424
2425 =head2 _ParseACLNewPrincipal
2426
2427 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>).  Looks
2428 for the presence of rights being added on a principal of the specified type,
2429 and returns undef if no new principal is being granted rights.  Otherwise loads
2430 up an L<RT::User> or L<RT::Group> object and returns it.  Note that the object
2431 may not be successfully loaded, and you should check C<->id> yourself.
2432
2433 =cut
2434
2435 sub _ParseACLNewPrincipal {
2436     my $ARGSref = shift;
2437     my $type    = lc shift;
2438     my $key     = "AddPrincipalForRights-$type";
2439
2440     return unless $ARGSref->{$key};
2441
2442     my $principal;
2443     if ( $type eq 'user' ) {
2444         $principal = RT::User->new( $session{'CurrentUser'} );
2445         $principal->LoadByCol( Name => $ARGSref->{$key} );
2446     }
2447     elsif ( $type eq 'group' ) {
2448         $principal = RT::Group->new( $session{'CurrentUser'} );
2449         $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2450     }
2451     return $principal;
2452 }
2453
2454
2455 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2456
2457 @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.
2458
2459 Returns an array of success/failure messages
2460
2461 =cut
2462
2463 sub UpdateRecordObject {
2464     my %args = (
2465         ARGSRef         => undef,
2466         AttributesRef   => undef,
2467         Object          => undef,
2468         AttributePrefix => undef,
2469         @_
2470     );
2471
2472     my $Object  = $args{'Object'};
2473     my @results = $Object->Update(
2474         AttributesRef   => $args{'AttributesRef'},
2475         ARGSRef         => $args{'ARGSRef'},
2476         AttributePrefix => $args{'AttributePrefix'},
2477     );
2478
2479     return (@results);
2480 }
2481
2482
2483
2484 sub ProcessCustomFieldUpdates {
2485     my %args = (
2486         CustomFieldObj => undef,
2487         ARGSRef        => undef,
2488         @_
2489     );
2490
2491     my $Object  = $args{'CustomFieldObj'};
2492     my $ARGSRef = $args{'ARGSRef'};
2493
2494     my @attribs = qw(Name Type Description Queue SortOrder);
2495     my @results = UpdateRecordObject(
2496         AttributesRef => \@attribs,
2497         Object        => $Object,
2498         ARGSRef       => $ARGSRef
2499     );
2500
2501     my $prefix = "CustomField-" . $Object->Id;
2502     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2503         my ( $addval, $addmsg ) = $Object->AddValue(
2504             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2505             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2506             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2507         );
2508         push( @results, $addmsg );
2509     }
2510
2511     my @delete_values
2512         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2513         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2514         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2515
2516     foreach my $id (@delete_values) {
2517         next unless defined $id;
2518         my ( $err, $msg ) = $Object->DeleteValue($id);
2519         push( @results, $msg );
2520     }
2521
2522     my $vals = $Object->Values();
2523     while ( my $cfv = $vals->Next() ) {
2524         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2525             if ( $cfv->SortOrder != $so ) {
2526                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2527                 push( @results, $msg );
2528             }
2529         }
2530     }
2531
2532     return (@results);
2533 }
2534
2535
2536
2537 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2538
2539 Returns an array of results messages.
2540
2541 =cut
2542
2543 sub ProcessTicketBasics {
2544
2545     my %args = (
2546         TicketObj => undef,
2547         ARGSRef   => undef,
2548         @_
2549     );
2550
2551     my $TicketObj = $args{'TicketObj'};
2552     my $ARGSRef   = $args{'ARGSRef'};
2553
2554     my $OrigOwner = $TicketObj->Owner;
2555
2556     # Set basic fields
2557     my @attribs = qw(
2558         Subject
2559         FinalPriority
2560         Priority
2561         TimeEstimated
2562         TimeWorked
2563         TimeLeft
2564         Type
2565         Status
2566         Queue
2567     );
2568
2569     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2570     for my $field (qw(Queue Owner)) {
2571         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2572             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2573             my $temp = $class->new(RT->SystemUser);
2574             $temp->Load( $ARGSRef->{$field} );
2575             if ( $temp->id ) {
2576                 $ARGSRef->{$field} = $temp->id;
2577             }
2578         }
2579     }
2580
2581     # Status isn't a field that can be set to a null value.
2582     # RT core complains if you try
2583     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2584
2585     my @results = UpdateRecordObject(
2586         AttributesRef => \@attribs,
2587         Object        => $TicketObj,
2588         ARGSRef       => $ARGSRef,
2589     );
2590
2591     # We special case owner changing, so we can use ForceOwnerChange
2592     if ( $ARGSRef->{'Owner'}
2593       && $ARGSRef->{'Owner'} !~ /\D/
2594       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2595         my ($ChownType);
2596         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2597             $ChownType = "Force";
2598         }
2599         else {
2600             $ChownType = "Set";
2601         }
2602
2603         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2604         push( @results, $msg );
2605     }
2606
2607     # }}}
2608
2609     return (@results);
2610 }
2611
2612 sub ProcessTicketReminders {
2613     my %args = (
2614         TicketObj => undef,
2615         ARGSRef   => undef,
2616         @_
2617     );
2618
2619     my $Ticket = $args{'TicketObj'};
2620     my $args   = $args{'ARGSRef'};
2621     my @results;
2622
2623     my $reminder_collection = $Ticket->Reminders->Collection;
2624
2625     if ( $args->{'update-reminders'} ) {
2626         while ( my $reminder = $reminder_collection->Next ) {
2627             my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2628             if (   $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2629                 my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
2630                 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2631
2632             }
2633             elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2634                 my ($status, $msg) = $Ticket->Reminders->Open($reminder);
2635                 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2636             }
2637
2638             if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2639                 my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2640                 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2641             }
2642
2643             if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2644                 my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2645                 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2646             }
2647
2648             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2649                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2650                 $DateObj->Set(
2651                     Format => 'unknown',
2652                     Value  => $args->{ 'Reminder-Due-' . $reminder->id }
2653                 );
2654                 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2655                     my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
2656                     push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2657                 }
2658             }
2659         }
2660     }
2661
2662     if ( $args->{'NewReminder-Subject'} ) {
2663         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2664         $due_obj->Set(
2665           Format => 'unknown',
2666           Value => $args->{'NewReminder-Due'}
2667         );
2668         my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2669             Subject => $args->{'NewReminder-Subject'},
2670             Owner   => $args->{'NewReminder-Owner'},
2671             Due     => $due_obj->ISO
2672         );
2673         if ( $add_id ) {
2674             push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2675         }
2676         else {
2677             push @results, $msg;
2678         }
2679     }
2680     return @results;
2681 }
2682
2683 sub ProcessTicketCustomFieldUpdates {
2684     my %args = @_;
2685     $args{'Object'} = delete $args{'TicketObj'};
2686     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2687
2688     # Build up a list of objects that we want to work with
2689     my %custom_fields_to_mod;
2690     foreach my $arg ( keys %$ARGSRef ) {
2691         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2692             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2693         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2694             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2695         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2696             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2697         }
2698     }
2699
2700     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2701 }
2702
2703 sub ProcessObjectCustomFieldUpdates {
2704     my %args    = @_;
2705     my $ARGSRef = $args{'ARGSRef'};
2706     my @results;
2707
2708     # Build up a list of objects that we want to work with
2709     my %custom_fields_to_mod;
2710     foreach my $arg ( keys %$ARGSRef ) {
2711
2712         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2713         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2714
2715         # For each of those objects, find out what custom fields we want to work with.
2716         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2717     }
2718
2719     # For each of those objects
2720     foreach my $class ( keys %custom_fields_to_mod ) {
2721         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2722             my $Object = $args{'Object'};
2723             $Object = $class->new( $session{'CurrentUser'} )
2724                 unless $Object && ref $Object eq $class;
2725
2726             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2727             unless ( $Object->id ) {
2728                 $RT::Logger->warning("Couldn't load object $class #$id");
2729                 next;
2730             }
2731
2732             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2733                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2734                 $CustomFieldObj->SetContextObject($Object);
2735                 $CustomFieldObj->LoadById($cf);
2736                 unless ( $CustomFieldObj->id ) {
2737                     $RT::Logger->warning("Couldn't load custom field #$cf");
2738                     next;
2739                 }
2740                 push @results,
2741                     _ProcessObjectCustomFieldUpdates(
2742                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2743                     Object      => $Object,
2744                     CustomField => $CustomFieldObj,
2745                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2746                     );
2747             }
2748         }
2749     }
2750     return @results;
2751 }
2752
2753 sub _ProcessObjectCustomFieldUpdates {
2754     my %args    = @_;
2755     my $cf      = $args{'CustomField'};
2756     my $cf_type = $cf->Type || '';
2757
2758     # Remove blank Values since the magic field will take care of this. Sometimes
2759     # the browser gives you a blank value which causes CFs to be processed twice
2760     if (   defined $args{'ARGS'}->{'Values'}
2761         && !length $args{'ARGS'}->{'Values'}
2762         && $args{'ARGS'}->{'Values-Magic'} )
2763     {
2764         delete $args{'ARGS'}->{'Values'};
2765     }
2766
2767     my @results;
2768     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2769
2770         # skip category argument
2771         next if $arg eq 'Category';
2772
2773         # and TimeUnits
2774         next if $arg eq 'Value-TimeUnits';
2775
2776         # since http won't pass in a form element with a null value, we need
2777         # to fake it
2778         if ( $arg eq 'Values-Magic' ) {
2779
2780             # We don't care about the magic, if there's really a values element;
2781             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2782             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2783
2784             # "Empty" values does not mean anything for Image and Binary fields
2785             next if $cf_type =~ /^(?:Image|Binary)$/;
2786
2787             $arg = 'Values';
2788             $args{'ARGS'}->{'Values'} = undef;
2789         }
2790
2791         my @values = ();
2792         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2793             @values = @{ $args{'ARGS'}->{$arg} };
2794         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2795             @values = ( $args{'ARGS'}->{$arg} );
2796         } else {
2797             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2798                 if defined $args{'ARGS'}->{$arg};
2799         }
2800         @values = grep length, map {
2801             s/\r+\n/\n/g;
2802             s/^\s+//;
2803             s/\s+$//;
2804             $_;
2805             }
2806             grep defined, @values;
2807
2808         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2809             foreach my $value (@values) {
2810                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2811                     Field => $cf->id,
2812                     Value => $value
2813                 );
2814                 push( @results, $msg );
2815             }
2816         } elsif ( $arg eq 'Upload' ) {
2817             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2818             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2819             push( @results, $msg );
2820         } elsif ( $arg eq 'DeleteValues' ) {
2821             foreach my $value (@values) {
2822                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2823                     Field => $cf,
2824                     Value => $value,
2825                 );
2826                 push( @results, $msg );
2827             }
2828         } elsif ( $arg eq 'DeleteValueIds' ) {
2829             foreach my $value (@values) {
2830                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2831                     Field   => $cf,
2832                     ValueId => $value,
2833                 );
2834                 push( @results, $msg );
2835             }
2836         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2837             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2838
2839             my %values_hash;
2840             foreach my $value (@values) {
2841                 if ( my $entry = $cf_values->HasEntry($value) ) {
2842                     $values_hash{ $entry->id } = 1;
2843                     next;
2844                 }
2845
2846                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2847                     Field => $cf,
2848                     Value => $value
2849                 );
2850                 push( @results, $msg );
2851                 $values_hash{$val} = 1 if $val;
2852             }
2853
2854             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2855             return @results if ( $cf->Type eq 'Date' && ! @values );
2856
2857             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2858             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2859
2860             $cf_values->RedoSearch;
2861             while ( my $cf_value = $cf_values->Next ) {
2862                 next if $values_hash{ $cf_value->id };
2863
2864                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2865                     Field   => $cf,
2866                     ValueId => $cf_value->id
2867                 );
2868                 push( @results, $msg );
2869             }
2870         } elsif ( $arg eq 'Values' ) {
2871             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2872
2873             # keep everything up to the point of difference, delete the rest
2874             my $delete_flag;
2875             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2876                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2877                     shift @values;
2878                     next;
2879                 }
2880
2881                 $delete_flag ||= 1;
2882                 $old_cf->Delete;
2883             }
2884
2885             # now add/replace extra things, if any
2886             foreach my $value (@values) {
2887                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2888                     Field => $cf,
2889                     Value => $value
2890                 );
2891                 push( @results, $msg );
2892             }
2893         } else {
2894             push(
2895                 @results,
2896                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2897                     $cf->Name, ref $args{'Object'},
2898                     $args{'Object'}->id
2899                 )
2900             );
2901         }
2902     }
2903     return @results;
2904 }
2905
2906
2907 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2908
2909 Returns an array of results messages.
2910
2911 =cut
2912
2913 sub ProcessTicketWatchers {
2914     my %args = (
2915         TicketObj => undef,
2916         ARGSRef   => undef,
2917         @_
2918     );
2919     my (@results);
2920
2921     my $Ticket  = $args{'TicketObj'};
2922     my $ARGSRef = $args{'ARGSRef'};
2923
2924     # Munge watchers
2925
2926     foreach my $key ( keys %$ARGSRef ) {
2927
2928         # Delete deletable watchers
2929         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2930             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2931                 PrincipalId => $2,
2932                 Type        => $1
2933             );
2934             push @results, $msg;
2935         }
2936
2937         # Delete watchers in the simple style demanded by the bulk manipulator
2938         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2939             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2940                 Email => $ARGSRef->{$key},
2941                 Type  => $1
2942             );
2943             push @results, $msg;
2944         }
2945
2946         # Add new wathchers by email address
2947         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2948             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2949         {
2950
2951             #They're in this order because otherwise $1 gets clobbered :/
2952             my ( $code, $msg ) = $Ticket->AddWatcher(
2953                 Type  => $ARGSRef->{$key},
2954                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2955             );
2956             push @results, $msg;
2957         }
2958
2959         #Add requestors in the simple style demanded by the bulk manipulator
2960         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2961             my ( $code, $msg ) = $Ticket->AddWatcher(
2962                 Type  => $1,
2963                 Email => $ARGSRef->{$key}
2964             );
2965             push @results, $msg;
2966         }
2967
2968         # Add new  watchers by owner
2969         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2970             my $principal_id = $1;
2971             my $form         = $ARGSRef->{$key};
2972             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2973                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2974
2975                 my ( $code, $msg ) = $Ticket->AddWatcher(
2976                     Type        => $value,
2977                     PrincipalId => $principal_id
2978                 );
2979                 push @results, $msg;
2980             }
2981         }
2982
2983     }
2984     return (@results);
2985 }
2986
2987
2988
2989 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2990
2991 Returns an array of results messages.
2992
2993 =cut
2994
2995 sub ProcessTicketDates {
2996     my %args = (
2997         TicketObj => undef,
2998         ARGSRef   => undef,
2999         @_
3000     );
3001
3002     my $Ticket  = $args{'TicketObj'};
3003     my $ARGSRef = $args{'ARGSRef'};
3004
3005     my (@results);
3006
3007     # Set date fields
3008     my @date_fields = qw(
3009         Told
3010         Resolved
3011         Starts
3012         Started
3013         Due
3014         WillResolve
3015     );
3016
3017     #Run through each field in this list. update the value if apropriate
3018     foreach my $field (@date_fields) {
3019         next unless exists $ARGSRef->{ $field . '_Date' };
3020         next if $ARGSRef->{ $field . '_Date' } eq '';
3021
3022         my ( $code, $msg );
3023
3024         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3025         $DateObj->Set(
3026             Format => 'unknown',
3027             Value  => $ARGSRef->{ $field . '_Date' }
3028         );
3029
3030         my $obj = $field . "Obj";
3031         if (    ( defined $DateObj->Unix )
3032             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3033         {
3034             my $method = "Set$field";
3035             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3036             push @results, "$msg";
3037         }
3038     }
3039
3040     # }}}
3041     return (@results);
3042 }
3043
3044
3045
3046 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3047
3048 Returns an array of results messages.
3049
3050 =cut
3051
3052 sub ProcessTicketLinks {
3053     my %args = (
3054         TicketObj => undef,
3055         ARGSRef   => undef,
3056         @_
3057     );
3058
3059     my $Ticket  = $args{'TicketObj'};
3060     my $ARGSRef = $args{'ARGSRef'};
3061
3062     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3063
3064     #Merge if we need to
3065     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3066         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3067         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3068         push @results, $msg;
3069     }
3070
3071     return (@results);
3072 }
3073
3074
3075 sub ProcessRecordLinks {
3076     my %args = (
3077         RecordObj => undef,
3078         ARGSRef   => undef,
3079         @_
3080     );
3081
3082     my $Record  = $args{'RecordObj'};
3083     my $ARGSRef = $args{'ARGSRef'};
3084
3085     my (@results);
3086
3087     # Delete links that are gone gone gone.
3088     foreach my $arg ( keys %$ARGSRef ) {
3089         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3090             my $base   = $1;
3091             my $type   = $2;
3092             my $target = $3;
3093
3094             my ( $val, $msg ) = $Record->DeleteLink(
3095                 Base   => $base,
3096                 Type   => $type,
3097                 Target => $target
3098             );
3099
3100             push @results, $msg;
3101
3102         }
3103
3104     }
3105
3106     my @linktypes = qw( DependsOn MemberOf RefersTo );
3107
3108     foreach my $linktype (@linktypes) {
3109         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3110             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3111                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3112
3113             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3114                 next unless $luri;
3115                 $luri =~ s/\s+$//;    # Strip trailing whitespace
3116                 my ( $val, $msg ) = $Record->AddLink(
3117                     Target => $luri,
3118                     Type   => $linktype
3119                 );
3120                 push @results, $msg;
3121             }
3122         }
3123         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3124             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3125                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3126
3127             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3128                 next unless $luri;
3129                 my ( $val, $msg ) = $Record->AddLink(
3130                     Base => $luri,
3131                     Type => $linktype
3132                 );
3133
3134                 push @results, $msg;
3135             }
3136         }
3137     }
3138
3139     return (@results);
3140 }
3141
3142 =head2 ProcessTransactionSquelching
3143
3144 Takes a hashref of the submitted form arguments, C<%ARGS>.
3145
3146 Returns a hash of squelched addresses.
3147
3148 =cut
3149
3150 sub ProcessTransactionSquelching {
3151     my $args    = shift;
3152     my %checked = map { $_ => 1 } grep { defined }
3153         (    ref $args->{'TxnSendMailTo'} eq "ARRAY"  ? @{$args->{'TxnSendMailTo'}} :
3154          defined $args->{'TxnSendMailTo'}             ?  ($args->{'TxnSendMailTo'}) :
3155                                                                              () );
3156     my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3157     return %squelched;
3158 }
3159
3160 =head2 _UploadedFile ( $arg );
3161
3162 Takes a CGI parameter name; if a file is uploaded under that name,
3163 return a hash reference suitable for AddCustomFieldValue's use:
3164 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3165
3166 Returns C<undef> if no files were uploaded in the C<$arg> field.
3167
3168 =cut
3169
3170 sub _UploadedFile {
3171     my $arg         = shift;
3172     my $cgi_object  = $m->cgi_object;
3173     my $fh          = $cgi_object->upload($arg) or return undef;
3174     my $upload_info = $cgi_object->uploadInfo($fh);
3175
3176     my $filename = "$fh";
3177     $filename =~ s#^.*[\\/]##;
3178     binmode($fh);
3179
3180     return {
3181         Value        => $filename,
3182         LargeContent => do { local $/; scalar <$fh> },
3183         ContentType  => $upload_info->{'Content-Type'},
3184     };
3185 }
3186
3187 sub GetColumnMapEntry {
3188     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3189
3190     # deal with the simplest thing first
3191     if ( $args{'Map'}{ $args{'Name'} } ) {
3192         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3193     }
3194
3195     # complex things
3196     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3197         $subkey =~ s/^\{(.*)\}$/$1/;
3198         return undef unless $args{'Map'}->{$mainkey};
3199         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3200             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3201
3202         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3203     }
3204     return undef;
3205 }
3206
3207 sub ProcessColumnMapValue {
3208     my $value = shift;
3209     my %args = ( Arguments => [], Escape => 1, @_ );
3210
3211     if ( ref $value ) {
3212         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3213             my @tmp = $value->( @{ $args{'Arguments'} } );
3214             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3215         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3216             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3217         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3218             return $$value;
3219         }
3220     }
3221
3222     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3223     return $value;
3224 }
3225
3226 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3227
3228 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3229 principal collections mapped from the categories given.
3230
3231 =cut
3232
3233 sub GetPrincipalsMap {
3234     my $object = shift;
3235     my @map;
3236     for (@_) {
3237         if (/System/) {
3238             my $system = RT::Groups->new($session{'CurrentUser'});
3239             $system->LimitToSystemInternalGroups();
3240             $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3241             push @map, [
3242                 'System' => $system,    # loc_left_pair
3243                 'Type'   => 1,
3244             ];
3245         }
3246         elsif (/Groups/) {
3247             my $groups = RT::Groups->new($session{'CurrentUser'});
3248             $groups->LimitToUserDefinedGroups();
3249             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3250
3251             # Only show groups who have rights granted on this object
3252             $groups->WithGroupRight(
3253                 Right   => '',
3254                 Object  => $object,
3255                 IncludeSystemRights => 0,
3256                 IncludeSubgroupMembers => 0,
3257             );
3258
3259             push @map, [
3260                 'User Groups' => $groups,   # loc_left_pair
3261                 'Name'        => 0
3262             ];
3263         }
3264         elsif (/Roles/) {
3265             my $roles = RT::Groups->new($session{'CurrentUser'});
3266
3267             if ($object->isa('RT::System')) {
3268                 $roles->LimitToRolesForSystem();
3269             }
3270             elsif ($object->isa('RT::Queue')) {
3271                 $roles->LimitToRolesForQueue($object->Id);
3272             }
3273             else {
3274                 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3275                 next;
3276             }
3277             $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3278             push @map, [
3279                 'Roles' => $roles,  # loc_left_pair
3280                 'Type'  => 1
3281             ];
3282         }
3283         elsif (/Users/) {
3284             my $Users = RT->PrivilegedUsers->UserMembersObj();
3285             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3286
3287             # Only show users who have rights granted on this object
3288             my $group_members = $Users->WhoHaveGroupRight(
3289                 Right   => '',
3290                 Object  => $object,
3291                 IncludeSystemRights => 0,
3292                 IncludeSubgroupMembers => 0,
3293             );
3294
3295             # Limit to UserEquiv groups
3296             my $groups = $Users->NewAlias('Groups');
3297             $Users->Join(
3298                 ALIAS1 => $groups,
3299                 FIELD1 => 'id',
3300                 ALIAS2 => $group_members,
3301                 FIELD2 => 'GroupId'
3302             );
3303             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3304             $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3305
3306
3307             my $display = sub {
3308                 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3309             };
3310             push @map, [
3311                 'Users' => $Users,  # loc_left_pair
3312                 $display => 0
3313             ];
3314         }
3315     }
3316     return @map;
3317 }
3318
3319 =head2 _load_container_object ( $type, $id );
3320
3321 Instantiate container object for saving searches.
3322
3323 =cut
3324
3325 sub _load_container_object {
3326     my ( $obj_type, $obj_id ) = @_;
3327     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3328 }
3329
3330 =head2 _parse_saved_search ( $arg );
3331
3332 Given a serialization string for saved search, and returns the
3333 container object and the search id.
3334
3335 =cut
3336
3337 sub _parse_saved_search {
3338     my $spec = shift;
3339     return unless $spec;
3340     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3341         return;
3342     }
3343     my $obj_type  = $1;
3344     my $obj_id    = $2;
3345     my $search_id = $3;
3346
3347     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3348 }
3349
3350 =head2 ScrubHTML content
3351
3352 Removes unsafe and undesired HTML from the passed content
3353
3354 =cut
3355
3356 my $SCRUBBER;
3357 sub ScrubHTML {
3358     my $Content = shift;
3359     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3360
3361     $Content = '' if !defined($Content);
3362     return $SCRUBBER->scrub($Content);
3363 }
3364
3365 =head2 _NewScrubber
3366
3367 Returns a new L<HTML::Scrubber> object.
3368
3369 If you need to be more lax about what HTML tags and attributes are allowed,
3370 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3371 following:
3372
3373     package HTML::Mason::Commands;
3374     # Let tables through
3375     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3376     1;
3377
3378 =cut
3379
3380 our @SCRUBBER_ALLOWED_TAGS = qw(
3381     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3382     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3383 );
3384
3385 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3386     # Match http, https, ftp, mailto and relative urls
3387     # XXX: we also scrub format strings with this module then allow simple config options
3388     href   => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3389     face   => 1,
3390     size   => 1,
3391     target => 1,
3392     style  => qr{
3393         ^(?:\s*
3394             (?:(?:background-)?color: \s*
3395                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
3396                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
3397                        [\w\-]+                                  # green, light-blue, etc.
3398                        )                            |
3399                text-align: \s* \w+                  |
3400                font-size: \s* [\w.\-]+              |
3401                font-family: \s* [\w\s"',.\-]+       |
3402                font-weight: \s* [\w\-]+             |
3403
3404                # MS Office styles, which are probably fine.  If we don't, then any
3405                # associated styles in the same attribute get stripped.
3406                mso-[\w\-]+?: \s* [\w\s"',.\-]+
3407             )\s* ;? \s*)
3408          +$ # one or more of these allowed properties from here 'till sunset
3409     }ix,
3410     dir    => qr/^(rtl|ltr)$/i,
3411     lang   => qr/^\w+(-\w+)?$/,
3412 );
3413
3414 our %SCRUBBER_RULES = ();
3415
3416 sub _NewScrubber {
3417     require HTML::Scrubber;
3418     my $scrubber = HTML::Scrubber->new();
3419     $scrubber->default(
3420         0,
3421         {
3422             %SCRUBBER_ALLOWED_ATTRIBUTES,
3423             '*' => 0, # require attributes be explicitly allowed
3424         },
3425     );
3426     $scrubber->deny(qw[*]);
3427     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3428     $scrubber->rules(%SCRUBBER_RULES);
3429
3430     # Scrubbing comments is vital since IE conditional comments can contain
3431     # arbitrary HTML and we'd pass it right on through.
3432     $scrubber->comment(0);
3433
3434     return $scrubber;
3435 }
3436
3437 =head2 JSON
3438
3439 Redispatches to L<RT::Interface::Web/EncodeJSON>
3440
3441 =cut
3442
3443 sub JSON {
3444     RT::Interface::Web::EncodeJSON(@_);
3445 }
3446
3447 package RT::Interface::Web;
3448 RT::Base->_ImportOverlays();
3449
3450 1;