rt/lib/RT/Interface/Web.pm

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