rt/lib/RT/Interface/Web.pm

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