rt/lib/RT/Interface/Web.pm

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