rt/lib/RT/Interface/Web.pm.orig

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