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