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 sub ProcessUpdateMessage {
1660
1661     my %args = (
1662         ARGSRef           => undef,
1663         TicketObj         => undef,
1664         SkipSignatureOnly => 1,
1665         @_
1666     );
1667
1668     if ( $args{ARGSRef}->{'UpdateAttachments'}
1669         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1670     {
1671         delete $args{ARGSRef}->{'UpdateAttachments'};
1672     }
1673
1674     # Strip the signature
1675     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1676         Content        => $args{ARGSRef}->{UpdateContent},
1677         ContentType    => $args{ARGSRef}->{UpdateContentType},
1678         StripSignature => $args{SkipSignatureOnly},
1679         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1680     );
1681
1682     my %txn_customfields;
1683
1684     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1685       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1686         next if $key =~ /(TimeUnits|Magic)$/;
1687         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1688       }
1689     }
1690
1691     # If, after stripping the signature, we have no message, create a
1692     # Touch transaction if necessary
1693     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1694         and not length $args{ARGSRef}->{'UpdateContent'} )
1695     {
1696         #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1697         #      $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1698         #          delete $args{ARGSRef}->{'UpdateTimeWorked'};
1699         #  }
1700
1701         my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1702         if ( $timetaken or grep {length $_} values %txn_customfields ) {
1703             my ( $Transaction, $Description, $Object ) =
1704                 $args{TicketObj}->Touch(
1705                   CustomFields => \%txn_customfields,
1706                   TimeTaken => $timetaken
1707                 );
1708             return $Description;
1709         }
1710         return;
1711     }
1712
1713     if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1714         $args{ARGSRef}->{'UpdateSubject'} = undef;
1715     }
1716
1717     my $Message = MakeMIMEEntity(
1718         Subject => $args{ARGSRef}->{'UpdateSubject'},
1719         Body    => $args{ARGSRef}->{'UpdateContent'},
1720         Type    => $args{ARGSRef}->{'UpdateContentType'},
1721     );
1722
1723     $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1724         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1725     ) );
1726     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1727     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1728         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1729     } else {
1730         $old_txn = $args{TicketObj}->Transactions->First();
1731     }
1732
1733     if ( my $msg = $old_txn->Message->First ) {
1734         RT::Interface::Email::SetInReplyTo(
1735             Message   => $Message,
1736             InReplyTo => $msg
1737         );
1738     }
1739
1740     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1741         $Message->make_multipart;
1742         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1743     }
1744
1745     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1746         require RT::Action::SendEmail;
1747         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1748             ref $args{ARGSRef}->{'AttachTickets'}
1749             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1750             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1751     }
1752
1753     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1754     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1755
1756     my %message_args = (
1757         CcMessageTo  => $cc,
1758         BccMessageTo => $bcc,
1759         Sign         => $args{ARGSRef}->{'Sign'},
1760         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1761         MIMEObj      => $Message,
1762         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1763         CustomFields => \%txn_customfields,
1764     );
1765
1766     my @temp_squelch;
1767     foreach my $type (qw(Cc AdminCc)) {
1768         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1769             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1770             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1771             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1772         }
1773     }
1774     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1775             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1776             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1777     }
1778
1779     if (@temp_squelch) {
1780         require RT::Action::SendEmail;
1781         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1782     }
1783
1784     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1785         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1786             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1787
1788             my $var   = ucfirst($1) . 'MessageTo';
1789             my $value = $2;
1790             if ( $message_args{$var} ) {
1791                 $message_args{$var} .= ", $value";
1792             } else {
1793                 $message_args{$var} = $value;
1794             }
1795         }
1796     }
1797
1798     my @results;
1799     # Do the update via the appropriate Ticket method
1800     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1801         my ( $Transaction, $Description, $Object ) =
1802             $args{TicketObj}->Comment(%message_args);
1803         push( @results, $Description );
1804         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1805     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1806         my ( $Transaction, $Description, $Object ) =
1807             $args{TicketObj}->Correspond(%message_args);
1808         push( @results, $Description );
1809         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1810     } else {
1811         push( @results,
1812             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1813     }
1814     return @results;
1815 }
1816
1817 # }}}
1818
1819 # {{{ sub MakeMIMEEntity
1820
1821 =head2 MakeMIMEEntity PARAMHASH
1822
1823 Takes a paramhash Subject, Body and AttachmentFieldName.
1824
1825 Also takes Form, Cc and Type as optional paramhash keys.
1826
1827   Returns a MIME::Entity.
1828
1829 =cut
1830
1831 sub MakeMIMEEntity {
1832
1833     #TODO document what else this takes.
1834     my %args = (
1835         Subject             => undef,
1836         From                => undef,
1837         Cc                  => undef,
1838         Body                => undef,
1839         AttachmentFieldName => undef,
1840         Type                => undef,
1841         @_,
1842     );
1843     my $Message = MIME::Entity->build(
1844         Type    => 'multipart/mixed',
1845         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1846             grep defined $args{$_}, qw(Subject From Cc)
1847     );
1848
1849     if ( defined $args{'Body'} && length $args{'Body'} ) {
1850
1851         # Make the update content have no 'weird' newlines in it
1852         $args{'Body'} =~ s/\r\n/\n/gs;
1853
1854         $Message->attach(
1855             Type    => $args{'Type'} || 'text/plain',
1856             Charset => 'UTF-8',
1857             Data    => $args{'Body'},
1858         );
1859     }
1860
1861     if ( $args{'AttachmentFieldName'} ) {
1862
1863         my $cgi_object = $m->cgi_object;
1864
1865         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1866
1867             my ( @content, $buffer );
1868             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1869                 push @content, $buffer;
1870             }
1871
1872             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1873
1874             # Prefer the cached name first over CGI.pm stringification.
1875             my $filename = $RT::Mason::CGI::Filename;
1876             $filename = "$filehandle" unless defined $filename;
1877             $filename = Encode::encode_utf8( $filename );
1878             $filename =~ s{^.*[\\/]}{};
1879
1880             $Message->attach(
1881                 Type     => $uploadinfo->{'Content-Type'},
1882                 Filename => $filename,
1883                 Data     => \@content,
1884             );
1885             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1886                 $Message->head->set( 'Subject' => $filename );
1887             }
1888         }
1889     }
1890
1891     $Message->make_singlepart;
1892
1893     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1894
1895     return ($Message);
1896
1897 }
1898
1899 # }}}
1900
1901 # {{{ sub ParseDateToISO
1902
1903 =head2 ParseDateToISO
1904
1905 Takes a date in an arbitrary format.
1906 Returns an ISO date and time in GMT
1907
1908 =cut
1909
1910 sub ParseDateToISO {
1911     my $date = shift;
1912
1913     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1914     $date_obj->Set(
1915         Format => 'unknown',
1916         Value  => $date
1917     );
1918     return ( $date_obj->ISO );
1919 }
1920
1921 # }}}
1922
1923 # {{{ sub ProcessACLChanges
1924
1925 sub ProcessACLChanges {
1926     my $ARGSref = shift;
1927
1928     my @results;
1929
1930     foreach my $arg ( keys %$ARGSref ) {
1931         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1932
1933         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1934
1935         my @rights;
1936         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1937             @rights = @{ $ARGSref->{$arg} };
1938         } else {
1939             @rights = $ARGSref->{$arg};
1940         }
1941         @rights = grep $_, @rights;
1942         next unless @rights;
1943
1944         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1945         $principal->Load($principal_id);
1946
1947         my $obj;
1948         if ( $object_type eq 'RT::System' ) {
1949             $obj = $RT::System;
1950         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1951             $obj = $object_type->new( $session{'CurrentUser'} );
1952             $obj->Load($object_id);
1953             unless ( $obj->id ) {
1954                 $RT::Logger->error("couldn't load $object_type #$object_id");
1955                 next;
1956             }
1957         } else {
1958             $RT::Logger->error("object type '$object_type' is incorrect");
1959             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1960             next;
1961         }
1962
1963         foreach my $right (@rights) {
1964             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1965             push( @results, $msg );
1966         }
1967     }
1968
1969     return (@results);
1970 }
1971
1972 # }}}
1973
1974 # {{{ sub UpdateRecordObj
1975
1976 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1977
1978 @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.
1979
1980 Returns an array of success/failure messages
1981
1982 =cut
1983
1984 sub UpdateRecordObject {
1985     my %args = (
1986         ARGSRef         => undef,
1987         AttributesRef   => undef,
1988         Object          => undef,
1989         AttributePrefix => undef,
1990         @_
1991     );
1992
1993     my $Object  = $args{'Object'};
1994     my @results = $Object->Update(
1995         AttributesRef   => $args{'AttributesRef'},
1996         ARGSRef         => $args{'ARGSRef'},
1997         AttributePrefix => $args{'AttributePrefix'},
1998     );
1999
2000     return (@results);
2001 }
2002
2003 # }}}
2004
2005 # {{{ Sub ProcessCustomFieldUpdates
2006
2007 sub ProcessCustomFieldUpdates {
2008     my %args = (
2009         CustomFieldObj => undef,
2010         ARGSRef        => undef,
2011         @_
2012     );
2013
2014     my $Object  = $args{'CustomFieldObj'};
2015     my $ARGSRef = $args{'ARGSRef'};
2016
2017     my @attribs = qw(Name Type Description Queue SortOrder);
2018     my @results = UpdateRecordObject(
2019         AttributesRef => \@attribs,
2020         Object        => $Object,
2021         ARGSRef       => $ARGSRef
2022     );
2023
2024     my $prefix = "CustomField-" . $Object->Id;
2025     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2026         my ( $addval, $addmsg ) = $Object->AddValue(
2027             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2028             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2029             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2030         );
2031         push( @results, $addmsg );
2032     }
2033
2034     my @delete_values
2035         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2036         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2037         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2038
2039     foreach my $id (@delete_values) {
2040         next unless defined $id;
2041         my ( $err, $msg ) = $Object->DeleteValue($id);
2042         push( @results, $msg );
2043     }
2044
2045     my $vals = $Object->Values();
2046     while ( my $cfv = $vals->Next() ) {
2047         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2048             if ( $cfv->SortOrder != $so ) {
2049                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2050                 push( @results, $msg );
2051             }
2052         }
2053     }
2054
2055     return (@results);
2056 }
2057
2058 # }}}
2059
2060 # {{{ sub ProcessTicketBasics
2061
2062 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2063
2064 Returns an array of results messages.
2065
2066 =cut
2067
2068 sub ProcessTicketBasics {
2069
2070     my %args = (
2071         TicketObj => undef,
2072         ARGSRef   => undef,
2073         @_
2074     );
2075
2076     my $TicketObj = $args{'TicketObj'};
2077     my $ARGSRef   = $args{'ARGSRef'};
2078
2079     # {{{ Set basic fields
2080     my @attribs = qw(
2081         Subject
2082         FinalPriority
2083         Priority
2084         TimeEstimated
2085         TimeWorked
2086         TimeLeft
2087         Type
2088         Status
2089         Queue
2090     );
2091
2092     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
2093         my $tempqueue = RT::Queue->new($RT::SystemUser);
2094         $tempqueue->Load( $ARGSRef->{'Queue'} );
2095         if ( $tempqueue->id ) {
2096             $ARGSRef->{'Queue'} = $tempqueue->id;
2097         }
2098     }
2099
2100     # Status isn't a field that can be set to a null value.
2101     # RT core complains if you try
2102     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2103
2104     my @results = UpdateRecordObject(
2105         AttributesRef => \@attribs,
2106         Object        => $TicketObj,
2107         ARGSRef       => $ARGSRef,
2108     );
2109
2110     # We special case owner changing, so we can use ForceOwnerChange
2111     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2112         my ($ChownType);
2113         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2114             $ChownType = "Force";
2115         } else {
2116             $ChownType = "Give";
2117         }
2118
2119         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2120         push( @results, $msg );
2121     }
2122
2123     # }}}
2124
2125     return (@results);
2126 }
2127
2128 # }}}
2129
2130 sub ProcessTicketCustomFieldUpdates {
2131     my %args = @_;
2132     $args{'Object'} = delete $args{'TicketObj'};
2133     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2134
2135     # Build up a list of objects that we want to work with
2136     my %custom_fields_to_mod;
2137     foreach my $arg ( keys %$ARGSRef ) {
2138         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2139             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2140         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2141             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2142         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2143             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2144         }
2145     }
2146
2147     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2148 }
2149
2150 sub ProcessObjectCustomFieldUpdates {
2151     my %args    = @_;
2152     my $ARGSRef = $args{'ARGSRef'};
2153     my @results;
2154
2155     # Build up a list of objects that we want to work with
2156     my %custom_fields_to_mod;
2157     foreach my $arg ( keys %$ARGSRef ) {
2158
2159         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2160         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2161
2162         # For each of those objects, find out what custom fields we want to work with.
2163         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2164     }
2165
2166     # For each of those objects
2167     foreach my $class ( keys %custom_fields_to_mod ) {
2168         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2169             my $Object = $args{'Object'};
2170             $Object = $class->new( $session{'CurrentUser'} )
2171                 unless $Object && ref $Object eq $class;
2172
2173             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2174             unless ( $Object->id ) {
2175                 $RT::Logger->warning("Couldn't load object $class #$id");
2176                 next;
2177             }
2178
2179             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2180                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2181                 $CustomFieldObj->SetContextObject($Object);
2182                 $CustomFieldObj->LoadById($cf);
2183                 unless ( $CustomFieldObj->id ) {
2184                     $RT::Logger->warning("Couldn't load custom field #$cf");
2185                     next;
2186                 }
2187                 push @results,
2188                     _ProcessObjectCustomFieldUpdates(
2189                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2190                     Object      => $Object,
2191                     CustomField => $CustomFieldObj,
2192                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2193                     );
2194             }
2195         }
2196     }
2197     return @results;
2198 }
2199
2200 sub _ProcessObjectCustomFieldUpdates {
2201     my %args    = @_;
2202     my $cf      = $args{'CustomField'};
2203     my $cf_type = $cf->Type;
2204
2205     # Remove blank Values since the magic field will take care of this. Sometimes
2206     # the browser gives you a blank value which causes CFs to be processed twice
2207     if (   defined $args{'ARGS'}->{'Values'}
2208         && !length $args{'ARGS'}->{'Values'}
2209         && $args{'ARGS'}->{'Values-Magic'} )
2210     {
2211         delete $args{'ARGS'}->{'Values'};
2212     }
2213
2214     my @results;
2215     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2216
2217         # skip category argument
2218         next if $arg eq 'Category';
2219
2220         # and TimeUnits
2221         next if $arg eq 'Value-TimeUnits';
2222
2223         # since http won't pass in a form element with a null value, we need
2224         # to fake it
2225         if ( $arg eq 'Values-Magic' ) {
2226
2227             # We don't care about the magic, if there's really a values element;
2228             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2229             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2230
2231             # "Empty" values does not mean anything for Image and Binary fields
2232             next if $cf_type =~ /^(?:Image|Binary)$/;
2233
2234             $arg = 'Values';
2235             $args{'ARGS'}->{'Values'} = undef;
2236         }
2237
2238         my @values = ();
2239         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2240             @values = @{ $args{'ARGS'}->{$arg} };
2241         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2242             @values = ( $args{'ARGS'}->{$arg} );
2243         } else {
2244             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2245                 if defined $args{'ARGS'}->{$arg};
2246         }
2247         @values = grep length, map {
2248             s/\r+\n/\n/g;
2249             s/^\s+//;
2250             s/\s+$//;
2251             $_;
2252             }
2253             grep defined, @values;
2254
2255         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2256             foreach my $value (@values) {
2257                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2258                     Field => $cf->id,
2259                     Value => $value
2260                 );
2261                 push( @results, $msg );
2262             }
2263         } elsif ( $arg eq 'Upload' ) {
2264             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2265             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2266             push( @results, $msg );
2267         } elsif ( $arg eq 'DeleteValues' ) {
2268             foreach my $value (@values) {
2269                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2270                     Field => $cf,
2271                     Value => $value,
2272                 );
2273                 push( @results, $msg );
2274             }
2275         } elsif ( $arg eq 'DeleteValueIds' ) {
2276             foreach my $value (@values) {
2277                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2278                     Field   => $cf,
2279                     ValueId => $value,
2280                 );
2281                 push( @results, $msg );
2282             }
2283         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2284             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2285
2286             my %values_hash;
2287             foreach my $value (@values) {
2288                 if ( my $entry = $cf_values->HasEntry($value) ) {
2289                     $values_hash{ $entry->id } = 1;
2290                     next;
2291                 }
2292
2293                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2294                     Field => $cf,
2295                     Value => $value
2296                 );
2297                 push( @results, $msg );
2298                 $values_hash{$val} = 1 if $val;
2299             }
2300
2301             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2302             return @results if ( $cf->Type eq 'Date' && ! @values );
2303
2304             $cf_values->RedoSearch;
2305             while ( my $cf_value = $cf_values->Next ) {
2306                 next if $values_hash{ $cf_value->id };
2307
2308                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2309                     Field   => $cf,
2310                     ValueId => $cf_value->id
2311                 );
2312                 push( @results, $msg );
2313             }
2314         } elsif ( $arg eq 'Values' ) {
2315             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2316
2317             # keep everything up to the point of difference, delete the rest
2318             my $delete_flag;
2319             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2320                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2321                     shift @values;
2322                     next;
2323                 }
2324
2325                 $delete_flag ||= 1;
2326                 $old_cf->Delete;
2327             }
2328
2329             # now add/replace extra things, if any
2330             foreach my $value (@values) {
2331                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2332                     Field => $cf,
2333                     Value => $value
2334                 );
2335                 push( @results, $msg );
2336             }
2337         } else {
2338             push(
2339                 @results,
2340                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2341                     $cf->Name, ref $args{'Object'},
2342                     $args{'Object'}->id
2343                 )
2344             );
2345         }
2346     }
2347     return @results;
2348 }
2349
2350 # {{{ sub ProcessTicketWatchers
2351
2352 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2353
2354 Returns an array of results messages.
2355
2356 =cut
2357
2358 sub ProcessTicketWatchers {
2359     my %args = (
2360         TicketObj => undef,
2361         ARGSRef   => undef,
2362         @_
2363     );
2364     my (@results);
2365
2366     my $Ticket  = $args{'TicketObj'};
2367     my $ARGSRef = $args{'ARGSRef'};
2368
2369     # Munge watchers
2370
2371     foreach my $key ( keys %$ARGSRef ) {
2372
2373         # Delete deletable watchers
2374         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2375             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2376                 PrincipalId => $2,
2377                 Type        => $1
2378             );
2379             push @results, $msg;
2380         }
2381
2382         # Delete watchers in the simple style demanded by the bulk manipulator
2383         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2384             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2385                 Email => $ARGSRef->{$key},
2386                 Type  => $1
2387             );
2388             push @results, $msg;
2389         }
2390
2391         # Add new wathchers by email address
2392         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2393             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2394         {
2395
2396             #They're in this order because otherwise $1 gets clobbered :/
2397             my ( $code, $msg ) = $Ticket->AddWatcher(
2398                 Type  => $ARGSRef->{$key},
2399                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2400             );
2401             push @results, $msg;
2402         }
2403
2404         #Add requestors in the simple style demanded by the bulk manipulator
2405         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2406             my ( $code, $msg ) = $Ticket->AddWatcher(
2407                 Type  => $1,
2408                 Email => $ARGSRef->{$key}
2409             );
2410             push @results, $msg;
2411         }
2412
2413         # Add new  watchers by owner
2414         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2415             my $principal_id = $1;
2416             my $form         = $ARGSRef->{$key};
2417             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2418                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2419
2420                 my ( $code, $msg ) = $Ticket->AddWatcher(
2421                     Type        => $value,
2422                     PrincipalId => $principal_id
2423                 );
2424                 push @results, $msg;
2425             }
2426         }
2427
2428     }
2429     return (@results);
2430 }
2431
2432 # }}}
2433
2434 # {{{ sub ProcessTicketDates
2435
2436 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2437
2438 Returns an array of results messages.
2439
2440 =cut
2441
2442 sub ProcessTicketDates {
2443     my %args = (
2444         TicketObj => undef,
2445         ARGSRef   => undef,
2446         @_
2447     );
2448
2449     my $Ticket  = $args{'TicketObj'};
2450     my $ARGSRef = $args{'ARGSRef'};
2451
2452     my (@results);
2453
2454     # {{{ Set date fields
2455     my @date_fields = qw(
2456         Told
2457         Resolved
2458         Starts
2459         Started
2460         Due
2461     );
2462
2463     #Run through each field in this list. update the value if apropriate
2464     foreach my $field (@date_fields) {
2465         next unless exists $ARGSRef->{ $field . '_Date' };
2466         next if $ARGSRef->{ $field . '_Date' } eq '';
2467
2468         my ( $code, $msg );
2469
2470         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2471         $DateObj->Set(
2472             Format => 'unknown',
2473             Value  => $ARGSRef->{ $field . '_Date' }
2474         );
2475
2476         my $obj = $field . "Obj";
2477         if (    ( defined $DateObj->Unix )
2478             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2479         {
2480             my $method = "Set$field";
2481             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2482             push @results, "$msg";
2483         }
2484     }
2485
2486     # }}}
2487     return (@results);
2488 }
2489
2490 # }}}
2491
2492 # {{{ sub ProcessTicketLinks
2493
2494 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2495
2496 Returns an array of results messages.
2497
2498 =cut
2499
2500 sub ProcessTicketLinks {
2501     my %args = (
2502         TicketObj => undef,
2503         ARGSRef   => undef,
2504         @_
2505     );
2506
2507     my $Ticket  = $args{'TicketObj'};
2508     my $ARGSRef = $args{'ARGSRef'};
2509
2510     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2511
2512     #Merge if we need to
2513     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2514         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2515         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2516         push @results, $msg;
2517     }
2518
2519     return (@results);
2520 }
2521
2522 # }}}
2523
2524 sub ProcessRecordLinks {
2525     my %args = (
2526         RecordObj => undef,
2527         ARGSRef   => undef,
2528         @_
2529     );
2530
2531     my $Record  = $args{'RecordObj'};
2532     my $ARGSRef = $args{'ARGSRef'};
2533
2534     my (@results);
2535
2536     # Delete links that are gone gone gone.
2537     foreach my $arg ( keys %$ARGSRef ) {
2538         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2539             my $base   = $1;
2540             my $type   = $2;
2541             my $target = $3;
2542
2543             my ( $val, $msg ) = $Record->DeleteLink(
2544                 Base   => $base,
2545                 Type   => $type,
2546                 Target => $target
2547             );
2548
2549             push @results, $msg;
2550
2551         }
2552
2553     }
2554
2555     my @linktypes = qw( DependsOn MemberOf RefersTo );
2556
2557     foreach my $linktype (@linktypes) {
2558         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2559             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2560                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2561
2562             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2563                 next unless $luri;
2564                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2565                 my ( $val, $msg ) = $Record->AddLink(
2566                     Target => $luri,
2567                     Type   => $linktype
2568                 );
2569                 push @results, $msg;
2570             }
2571         }
2572         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2573             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2574                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2575
2576             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2577                 next unless $luri;
2578                 my ( $val, $msg ) = $Record->AddLink(
2579                     Base => $luri,
2580                     Type => $linktype
2581                 );
2582
2583                 push @results, $msg;
2584             }
2585         }
2586     }
2587
2588     return (@results);
2589 }
2590
2591 =head2 _UploadedFile ( $arg );
2592
2593 Takes a CGI parameter name; if a file is uploaded under that name,
2594 return a hash reference suitable for AddCustomFieldValue's use:
2595 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2596
2597 Returns C<undef> if no files were uploaded in the C<$arg> field.
2598
2599 =cut
2600
2601 sub _UploadedFile {
2602     my $arg         = shift;
2603     my $cgi_object  = $m->cgi_object;
2604     my $fh          = $cgi_object->upload($arg) or return undef;
2605     my $upload_info = $cgi_object->uploadInfo($fh);
2606
2607     my $filename = "$fh";
2608     $filename =~ s#^.*[\\/]##;
2609     binmode($fh);
2610
2611     return {
2612         Value        => $filename,
2613         LargeContent => do { local $/; scalar <$fh> },
2614         ContentType  => $upload_info->{'Content-Type'},
2615     };
2616 }
2617
2618 sub GetColumnMapEntry {
2619     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2620
2621     # deal with the simplest thing first
2622     if ( $args{'Map'}{ $args{'Name'} } ) {
2623         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2624     }
2625
2626     # complex things
2627     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2628         return undef unless $args{'Map'}->{$mainkey};
2629         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2630             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2631
2632         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2633     }
2634     return undef;
2635 }
2636
2637 sub ProcessColumnMapValue {
2638     my $value = shift;
2639     my %args = ( Arguments => [], Escape => 1, @_ );
2640
2641     if ( ref $value ) {
2642         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2643             my @tmp = $value->( @{ $args{'Arguments'} } );
2644             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2645         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2646             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2647         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2648             return $$value;
2649         }
2650     }
2651
2652     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2653     return $value;
2654 }
2655
2656 =head2 _load_container_object ( $type, $id );
2657
2658 Instantiate container object for saving searches.
2659
2660 =cut
2661
2662 sub _load_container_object {
2663     my ( $obj_type, $obj_id ) = @_;
2664     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2665 }
2666
2667 =head2 _parse_saved_search ( $arg );
2668
2669 Given a serialization string for saved search, and returns the
2670 container object and the search id.
2671
2672 =cut
2673
2674 sub _parse_saved_search {
2675     my $spec = shift;
2676     return unless $spec;
2677     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2678         return;
2679     }
2680     my $obj_type  = $1;
2681     my $obj_id    = $2;
2682     my $search_id = $3;
2683
2684     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2685 }
2686
2687 =head2 ScrubHTML content
2688
2689 Removes unsafe and undesired HTML from the passed content
2690
2691 =cut
2692
2693 my $SCRUBBER;
2694 sub ScrubHTML {
2695     my $Content = shift;
2696     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2697
2698     $Content = '' if !defined($Content);
2699     return $SCRUBBER->scrub($Content);
2700 }
2701
2702 =head2 _NewScrubber
2703
2704 Returns a new L<HTML::Scrubber> object.
2705
2706 If you need to be more lax about what HTML tags and attributes are allowed,
2707 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2708 following:
2709
2710     package HTML::Mason::Commands;
2711     # Let tables through
2712     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2713     1;
2714
2715 =cut
2716
2717 our @SCRUBBER_ALLOWED_TAGS = qw(
2718     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2719     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2720 );
2721
2722 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2723     # Match http, ftp and relative urls
2724     # XXX: we also scrub format strings with this module then allow simple config options
2725     href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2726     face   => 1,
2727     size   => 1,
2728     target => 1,
2729     style  => qr{
2730         ^(?:\s*
2731             (?:(?:background-)?color: \s*
2732                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
2733                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
2734                        [\w\-]+                                  # green, light-blue, etc.
2735                        )                            |
2736                text-align: \s* \w+                  |
2737                font-size: \s* [\w.\-]+              |
2738                font-family: \s* [\w\s"',.\-]+       |
2739                font-weight: \s* [\w\-]+             |
2740
2741                # MS Office styles, which are probably fine.  If we don't, then any
2742                # associated styles in the same attribute get stripped.
2743                mso-[\w\-]+?: \s* [\w\s"',.\-]+
2744             )\s* ;? \s*)
2745          +$ # one or more of these allowed properties from here 'till sunset
2746     }ix,
2747 );
2748
2749 our %SCRUBBER_RULES = ();
2750
2751 sub _NewScrubber {
2752     require HTML::Scrubber;
2753     my $scrubber = HTML::Scrubber->new();
2754     $scrubber->default(
2755         0,
2756         {
2757             %SCRUBBER_ALLOWED_ATTRIBUTES,
2758             '*' => 0, # require attributes be explicitly allowed
2759         },
2760     );
2761     $scrubber->deny(qw[*]);
2762     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2763     $scrubber->rules(%SCRUBBER_RULES);
2764
2765     # Scrubbing comments is vital since IE conditional comments can contain
2766     # arbitrary HTML and we'd pass it right on through.
2767     $scrubber->comment(0);
2768
2769     return $scrubber;
2770 }
2771
2772 package RT::Interface::Web;
2773 RT::Base->_ImportOverlays();
2774
2775 1;