rt/lib/RT/Interface/Web.pm

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