lib/RT/Interface/Web.pm

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