rt/lib/RT/Interface/Web.pm

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