rt/lib/RT/Interface/Web.pm

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