rt/lib/RT/Interface/Web.pm

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