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     if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1114         $RT::Logger->warn("The actual SCRIPT_NAME ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1115     }
1116 }
1117
1118 sub ComponentRoots {
1119     my $self = shift;
1120     my %args = ( Names => 0, @_ );
1121     my @roots;
1122     if (defined $HTML::Mason::Commands::m) {
1123         @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1124     } else {
1125         @roots = (
1126             [ local    => $RT::MasonLocalComponentRoot ],
1127             (map {[ "plugin-".$_->Name =>  $_->ComponentRoot ]} @{RT->Plugins}),
1128             [ standard => $RT::MasonComponentRoot ]
1129         );
1130     }
1131     @roots = map { $_->[1] } @roots unless $args{Names};
1132     return @roots;
1133 }
1134
1135 package HTML::Mason::Commands;
1136
1137 use vars qw/$r $m %session/;
1138
1139 sub Menu {
1140     return $HTML::Mason::Commands::m->notes('menu');
1141 }
1142
1143 sub PageMenu {
1144     return $HTML::Mason::Commands::m->notes('page-menu');
1145 }
1146
1147 sub PageWidgets {
1148     return $HTML::Mason::Commands::m->notes('page-widgets');
1149 }
1150
1151
1152
1153 =head2 loc ARRAY
1154
1155 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1156 with whatever it's called with. If there is no $session{'CurrentUser'},
1157 it creates a temporary user, so we have something to get a localisation handle
1158 through
1159
1160 =cut
1161
1162 sub loc {
1163
1164     if ( $session{'CurrentUser'}
1165         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1166     {
1167         return ( $session{'CurrentUser'}->loc(@_) );
1168     } elsif (
1169         my $u = eval {
1170             RT::CurrentUser->new();
1171         }
1172         )
1173     {
1174         return ( $u->loc(@_) );
1175     } else {
1176
1177         # pathetic case -- SystemUser is gone.
1178         return $_[0];
1179     }
1180 }
1181
1182
1183
1184 =head2 loc_fuzzy STRING
1185
1186 loc_fuzzy is for handling localizations of messages that may already
1187 contain interpolated variables, typically returned from libraries
1188 outside RT's control.  It takes the message string and extracts the
1189 variable array automatically by matching against the candidate entries
1190 inside the lexicon file.
1191
1192 =cut
1193
1194 sub loc_fuzzy {
1195     my $msg = shift;
1196
1197     if ( $session{'CurrentUser'}
1198         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1199     {
1200         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1201     } else {
1202         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1203         return ( $u->loc_fuzzy($msg) );
1204     }
1205 }
1206
1207
1208 # Error - calls Error and aborts
1209 sub Abort {
1210     my $why  = shift;
1211     my %args = @_;
1212
1213     if (   $session{'ErrorDocument'}
1214         && $session{'ErrorDocumentType'} )
1215     {
1216         $r->content_type( $session{'ErrorDocumentType'} );
1217         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1218         $m->abort;
1219     } else {
1220         $m->comp( "/Elements/Error", Why => $why, %args );
1221         $m->abort;
1222     }
1223 }
1224
1225 sub MaybeRedirectForResults {
1226     my %args = (
1227         Path      => $HTML::Mason::Commands::m->request_comp->path,
1228         Arguments => {},
1229         Anchor    => undef,
1230         Actions   => undef,
1231         Force     => 0,
1232         @_
1233     );
1234     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1235     return unless $has_actions || $args{'Force'};
1236
1237     my %arguments = %{ $args{'Arguments'} };
1238
1239     if ( $has_actions ) {
1240         my $key = Digest::MD5::md5_hex( rand(1024) );
1241         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1242         $session{'i'}++;
1243         $arguments{'results'} = $key;
1244     }
1245
1246     $args{'Path'} =~ s!^/+!!;
1247     my $url = RT->Config->Get('WebURL') . $args{Path};
1248
1249     if ( keys %arguments ) {
1250         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1251     }
1252     if ( $args{'Anchor'} ) {
1253         $url .= "#". $args{'Anchor'};
1254     }
1255     return RT::Interface::Web::Redirect($url);
1256 }
1257
1258 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1259
1260 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1261 redirect to the approvals display page, preserving any arguments.
1262
1263 C<Path>s matching C<Whitelist> are let through.
1264
1265 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1266
1267 =cut
1268
1269 sub MaybeRedirectToApproval {
1270     my %args = (
1271         Path        => $HTML::Mason::Commands::m->request_comp->path,
1272         ARGSRef     => {},
1273         Whitelist   => undef,
1274         @_
1275     );
1276
1277     return unless $ENV{REQUEST_METHOD} eq 'GET';
1278
1279     my $id = $args{ARGSRef}->{id};
1280
1281     if (    $id
1282         and RT->Config->Get('ForceApprovalsView')
1283         and not $args{Path} =~ /$args{Whitelist}/)
1284     {
1285         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1286         $ticket->Load($id);
1287
1288         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1289             MaybeRedirectForResults(
1290                 Path      => "/Approvals/Display.html",
1291                 Force     => 1,
1292                 Anchor    => $args{ARGSRef}->{Anchor},
1293                 Arguments => $args{ARGSRef},
1294             );
1295         }
1296     }
1297 }
1298
1299 =head2 CreateTicket ARGS
1300
1301 Create a new ticket, using Mason's %ARGS.  returns @results.
1302
1303 =cut
1304
1305 sub CreateTicket {
1306     my %ARGS = (@_);
1307
1308     my (@Actions);
1309
1310     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1311
1312     my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1313     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1314         Abort('Queue not found');
1315     }
1316
1317     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1318         Abort('You have no permission to create tickets in that queue.');
1319     }
1320
1321     my $due;
1322     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1323         $due = RT::Date->new( $session{'CurrentUser'} );
1324         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1325     }
1326     my $starts;
1327     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1328         $starts = RT::Date->new( $session{'CurrentUser'} );
1329         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1330     }
1331
1332     my $sigless = RT::Interface::Web::StripContent(
1333         Content        => $ARGS{Content},
1334         ContentType    => $ARGS{ContentType},
1335         StripSignature => 1,
1336         CurrentUser    => $session{'CurrentUser'},
1337     );
1338
1339     my $MIMEObj = MakeMIMEEntity(
1340         Subject => $ARGS{'Subject'},
1341         From    => $ARGS{'From'},
1342         Cc      => $ARGS{'Cc'},
1343         Body    => $sigless,
1344         Type    => $ARGS{'ContentType'},
1345     );
1346
1347     if ( $ARGS{'Attachments'} ) {
1348         my $rv = $MIMEObj->make_multipart;
1349         $RT::Logger->error("Couldn't make multipart message")
1350             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1351
1352         foreach ( values %{ $ARGS{'Attachments'} } ) {
1353             unless ($_) {
1354                 $RT::Logger->error("Couldn't add empty attachemnt");
1355                 next;
1356             }
1357             $MIMEObj->add_part($_);
1358         }
1359     }
1360
1361     foreach my $argument (qw(Encrypt Sign)) {
1362         $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1363           if defined $ARGS{$argument};
1364     }
1365
1366     my %create_args = (
1367         Type => $ARGS{'Type'} || 'ticket',
1368         Queue => $ARGS{'Queue'},
1369         Owner => $ARGS{'Owner'},
1370
1371         # note: name change
1372         Requestor       => $ARGS{'Requestors'},
1373         Cc              => $ARGS{'Cc'},
1374         AdminCc         => $ARGS{'AdminCc'},
1375         InitialPriority => $ARGS{'InitialPriority'},
1376         FinalPriority   => $ARGS{'FinalPriority'},
1377         TimeLeft        => $ARGS{'TimeLeft'},
1378         TimeEstimated   => $ARGS{'TimeEstimated'},
1379         TimeWorked      => $ARGS{'TimeWorked'},
1380         Subject         => $ARGS{'Subject'},
1381         Status          => $ARGS{'Status'},
1382         Due             => $due ? $due->ISO : undef,
1383         Starts          => $starts ? $starts->ISO : undef,
1384         MIMEObj         => $MIMEObj
1385     );
1386
1387     my @txn_squelch;
1388     foreach my $type (qw(Requestor Cc AdminCc)) {
1389         push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1390             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1391     }
1392     $create_args{TransSquelchMailTo} = \@txn_squelch
1393         if @txn_squelch;
1394
1395     if ( $ARGS{'AttachTickets'} ) {
1396         require RT::Action::SendEmail;
1397         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1398             ref $ARGS{'AttachTickets'}
1399             ? @{ $ARGS{'AttachTickets'} }
1400             : ( $ARGS{'AttachTickets'} ) );
1401     }
1402
1403     foreach my $arg ( keys %ARGS ) {
1404         next if $arg =~ /-(?:Magic|Category)$/;
1405
1406         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1407             $create_args{$arg} = $ARGS{$arg};
1408         }
1409
1410         # Object-RT::Ticket--CustomField-3-Values
1411         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1412             my $cfid = $1;
1413
1414             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1415             $cf->Load($cfid);
1416             unless ( $cf->id ) {
1417                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1418                 next;
1419             }
1420
1421             if ( $arg =~ /-Upload$/ ) {
1422                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1423                 next;
1424             }
1425
1426             my $type = $cf->Type;
1427
1428             my @values = ();
1429             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1430                 @values = @{ $ARGS{$arg} };
1431             } elsif ( $type =~ /text/i ) {
1432                 @values = ( $ARGS{$arg} );
1433             } else {
1434                 no warnings 'uninitialized';
1435                 @values = split /\r*\n/, $ARGS{$arg};
1436             }
1437             @values = grep length, map {
1438                 s/\r+\n/\n/g;
1439                 s/^\s+//;
1440                 s/\s+$//;
1441                 $_;
1442                 }
1443                 grep defined, @values;
1444
1445             $create_args{"CustomField-$cfid"} = \@values;
1446         }
1447     }
1448
1449     # turn new link lists into arrays, and pass in the proper arguments
1450     my %map = (
1451         'new-DependsOn' => 'DependsOn',
1452         'DependsOn-new' => 'DependedOnBy',
1453         'new-MemberOf'  => 'Parents',
1454         'MemberOf-new'  => 'Children',
1455         'new-RefersTo'  => 'RefersTo',
1456         'RefersTo-new'  => 'ReferredToBy',
1457     );
1458     foreach my $key ( keys %map ) {
1459         next unless $ARGS{$key};
1460         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1461
1462     }
1463
1464     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1465     unless ($id) {
1466         Abort($ErrMsg);
1467     }
1468
1469     push( @Actions, split( "\n", $ErrMsg ) );
1470     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1471         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1472     }
1473     return ( $Ticket, @Actions );
1474
1475 }
1476
1477
1478
1479 =head2  LoadTicket id
1480
1481 Takes a ticket id as its only variable. if it's handed an array, it takes
1482 the first value.
1483
1484 Returns an RT::Ticket object as the current user.
1485
1486 =cut
1487
1488 sub LoadTicket {
1489     my $id = shift;
1490
1491     if ( ref($id) eq "ARRAY" ) {
1492         $id = $id->[0];
1493     }
1494
1495     unless ($id) {
1496         Abort("No ticket specified");
1497     }
1498
1499     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1500     $Ticket->Load($id);
1501     unless ( $Ticket->id ) {
1502         Abort("Could not load ticket $id");
1503     }
1504     return $Ticket;
1505 }
1506
1507
1508
1509 =head2 ProcessUpdateMessage
1510
1511 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1512
1513 Don't write message if it only contains current user's signature and
1514 SkipSignatureOnly argument is true. Function anyway adds attachments
1515 and updates time worked field even if skips message. The default value
1516 is true.
1517
1518 =cut
1519
1520 sub ProcessUpdateMessage {
1521
1522     my %args = (
1523         ARGSRef           => undef,
1524         TicketObj         => undef,
1525         SkipSignatureOnly => 1,
1526         @_
1527     );
1528
1529     if ( $args{ARGSRef}->{'UpdateAttachments'}
1530         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1531     {
1532         delete $args{ARGSRef}->{'UpdateAttachments'};
1533     }
1534
1535     # Strip the signature
1536     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1537         Content        => $args{ARGSRef}->{UpdateContent},
1538         ContentType    => $args{ARGSRef}->{UpdateContentType},
1539         StripSignature => $args{SkipSignatureOnly},
1540         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1541     );
1542
1543     # If, after stripping the signature, we have no message, move the
1544     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1545     # ProcessBasics can deal -- then bail out.
1546     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1547         and not length $args{ARGSRef}->{'UpdateContent'} )
1548     {
1549         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1550             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1551         }
1552         return;
1553     }
1554
1555     if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1556         $args{ARGSRef}->{'UpdateSubject'} = undef;
1557     }
1558
1559     my $Message = MakeMIMEEntity(
1560         Subject => $args{ARGSRef}->{'UpdateSubject'},
1561         Body    => $args{ARGSRef}->{'UpdateContent'},
1562         Type    => $args{ARGSRef}->{'UpdateContentType'},
1563     );
1564
1565     $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1566         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1567     ) );
1568     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1569     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1570         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1571     } else {
1572         $old_txn = $args{TicketObj}->Transactions->First();
1573     }
1574
1575     if ( my $msg = $old_txn->Message->First ) {
1576         RT::Interface::Email::SetInReplyTo(
1577             Message   => $Message,
1578             InReplyTo => $msg
1579         );
1580     }
1581
1582     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1583         $Message->make_multipart;
1584         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1585     }
1586
1587     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1588         require RT::Action::SendEmail;
1589         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1590             ref $args{ARGSRef}->{'AttachTickets'}
1591             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1592             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1593     }
1594
1595     my %txn_customfields;
1596
1597     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1598       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1599         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1600       }
1601     }
1602
1603     my %message_args = (
1604         Sign         => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1605         Encrypt      => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1606         MIMEObj      => $Message,
1607         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1608         CustomFields => \%txn_customfields,
1609     );
1610
1611     _ProcessUpdateMessageRecipients(
1612         MessageArgs => \%message_args,
1613         %args,
1614     );
1615
1616     my @results;
1617     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1618         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1619         push( @results, $Description );
1620         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1621     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1622         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1623         push( @results, $Description );
1624         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1625     } else {
1626         push( @results,
1627             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1628     }
1629     return @results;
1630 }
1631
1632 sub _ProcessUpdateMessageRecipients {
1633     my %args = (
1634         ARGSRef           => undef,
1635         TicketObj         => undef,
1636         MessageArgs       => undef,
1637         @_,
1638     );
1639
1640     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1641     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1642
1643     my $message_args = $args{MessageArgs};
1644
1645     $message_args->{CcMessageTo} = $cc;
1646     $message_args->{BccMessageTo} = $bcc;
1647
1648     my @txn_squelch;
1649     foreach my $type (qw(Cc AdminCc)) {
1650         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1651             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1652             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1653             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1654         }
1655     }
1656     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1657         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1658         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1659
1660     }
1661
1662     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1663     $message_args->{SquelchMailTo} = \@txn_squelch
1664         if @txn_squelch;
1665
1666     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1667         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1668             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1669
1670             my $var   = ucfirst($1) . 'MessageTo';
1671             my $value = $2;
1672             if ( $message_args->{$var} ) {
1673                 $message_args->{$var} .= ", $value";
1674             } else {
1675                 $message_args->{$var} = $value;
1676             }
1677         }
1678     }
1679 }
1680
1681 =head2 MakeMIMEEntity PARAMHASH
1682
1683 Takes a paramhash Subject, Body and AttachmentFieldName.
1684
1685 Also takes Form, Cc and Type as optional paramhash keys.
1686
1687   Returns a MIME::Entity.
1688
1689 =cut
1690
1691 sub MakeMIMEEntity {
1692
1693     #TODO document what else this takes.
1694     my %args = (
1695         Subject             => undef,
1696         From                => undef,
1697         Cc                  => undef,
1698         Body                => undef,
1699         AttachmentFieldName => undef,
1700         Type                => undef,
1701         @_,
1702     );
1703     my $Message = MIME::Entity->build(
1704         Type    => 'multipart/mixed',
1705         "Message-Id" => RT::Interface::Email::GenMessageId,
1706         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1707             grep defined $args{$_}, qw(Subject From Cc)
1708     );
1709
1710     if ( defined $args{'Body'} && length $args{'Body'} ) {
1711
1712         # Make the update content have no 'weird' newlines in it
1713         $args{'Body'} =~ s/\r\n/\n/gs;
1714
1715         $Message->attach(
1716             Type    => $args{'Type'} || 'text/plain',
1717             Charset => 'UTF-8',
1718             Data    => $args{'Body'},
1719         );
1720     }
1721
1722     if ( $args{'AttachmentFieldName'} ) {
1723
1724         my $cgi_object = $m->cgi_object;
1725         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1726         if ( defined $filehandle && length $filehandle ) {
1727
1728             my ( @content, $buffer );
1729             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1730                 push @content, $buffer;
1731             }
1732
1733             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1734
1735             my $filename = "$filehandle";
1736             $filename =~ s{^.*[\\/]}{};
1737
1738             $Message->attach(
1739                 Type     => $uploadinfo->{'Content-Type'},
1740                 Filename => $filename,
1741                 Data     => \@content,
1742             );
1743             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1744                 $Message->head->set( 'Subject' => $filename );
1745             }
1746
1747             # Attachment parts really shouldn't get a Message-ID
1748             $Message->head->delete('Message-ID');
1749         }
1750     }
1751
1752     $Message->make_singlepart;
1753
1754     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1755
1756     return ($Message);
1757
1758 }
1759
1760
1761
1762 =head2 ParseDateToISO
1763
1764 Takes a date in an arbitrary format.
1765 Returns an ISO date and time in GMT
1766
1767 =cut
1768
1769 sub ParseDateToISO {
1770     my $date = shift;
1771
1772     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1773     $date_obj->Set(
1774         Format => 'unknown',
1775         Value  => $date
1776     );
1777     return ( $date_obj->ISO );
1778 }
1779
1780
1781
1782 sub ProcessACLChanges {
1783     my $ARGSref = shift;
1784
1785     my @results;
1786
1787     foreach my $arg ( keys %$ARGSref ) {
1788         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1789
1790         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1791
1792         my @rights;
1793         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1794             @rights = @{ $ARGSref->{$arg} };
1795         } else {
1796             @rights = $ARGSref->{$arg};
1797         }
1798         @rights = grep $_, @rights;
1799         next unless @rights;
1800
1801         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1802         $principal->Load($principal_id);
1803
1804         my $obj;
1805         if ( $object_type eq 'RT::System' ) {
1806             $obj = $RT::System;
1807         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1808             $obj = $object_type->new( $session{'CurrentUser'} );
1809             $obj->Load($object_id);
1810             unless ( $obj->id ) {
1811                 $RT::Logger->error("couldn't load $object_type #$object_id");
1812                 next;
1813             }
1814         } else {
1815             $RT::Logger->error("object type '$object_type' is incorrect");
1816             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1817             next;
1818         }
1819
1820         foreach my $right (@rights) {
1821             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1822             push( @results, $msg );
1823         }
1824     }
1825
1826     return (@results);
1827 }
1828
1829
1830 =head2 ProcessACLs
1831
1832 ProcessACLs expects values from a series of checkboxes that describe the full
1833 set of rights a principal should have on an object.
1834
1835 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
1836 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
1837 listing the rights the principal should have, and ProcessACLs will modify the
1838 current rights to match.  Additionally, the previously unused CheckACL input
1839 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
1840 rights are removed from a principal and as such no SetRights input is
1841 submitted.
1842
1843 =cut
1844
1845 sub ProcessACLs {
1846     my $ARGSref = shift;
1847     my (%state, @results);
1848
1849     my $CheckACL = $ARGSref->{'CheckACL'};
1850     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
1851
1852     # Check if we want to grant rights to a previously rights-less user
1853     for my $type (qw(user group)) {
1854         my $key = "AddPrincipalForRights-$type";
1855
1856         next unless $ARGSref->{$key};
1857
1858         my $principal;
1859         if ( $type eq 'user' ) {
1860             $principal = RT::User->new( $session{'CurrentUser'} );
1861             $principal->LoadByCol( Name => $ARGSref->{$key} );
1862         }
1863         else {
1864             $principal = RT::Group->new( $session{'CurrentUser'} );
1865             $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
1866         }
1867
1868         unless ($principal->PrincipalId) {
1869             push @results, loc("Couldn't load the specified principal");
1870             next;
1871         }
1872
1873         my $principal_id = $principal->PrincipalId;
1874
1875         # Turn our addprincipal rights spec into a real one
1876         for my $arg (keys %$ARGSref) {
1877             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
1878
1879             my $tuple = "$principal_id-$1";
1880             my $key   = "SetRights-$tuple";
1881
1882             # If we have it already, that's odd, but merge them
1883             if (grep { $_ eq $tuple } @check) {
1884                 $ARGSref->{$key} = [
1885                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
1886                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
1887                 ];
1888             } else {
1889                 $ARGSref->{$key} = $ARGSref->{$arg};
1890                 push @check, $tuple;
1891             }
1892         }
1893     }
1894
1895     # Build our rights state for each Principal-Object tuple
1896     foreach my $arg ( keys %$ARGSref ) {
1897         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
1898
1899         my $tuple  = $1;
1900         my $value  = $ARGSref->{$arg};
1901         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
1902         next unless @rights;
1903
1904         $state{$tuple} = { map { $_ => 1 } @rights };
1905     }
1906
1907     foreach my $tuple (List::MoreUtils::uniq @check) {
1908         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
1909
1910         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
1911
1912         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1913         $principal->Load($principal_id);
1914
1915         my $obj;
1916         if ( $object_type eq 'RT::System' ) {
1917             $obj = $RT::System;
1918         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1919             $obj = $object_type->new( $session{'CurrentUser'} );
1920             $obj->Load($object_id);
1921             unless ( $obj->id ) {
1922                 $RT::Logger->error("couldn't load $object_type #$object_id");
1923                 next;
1924             }
1925         } else {
1926             $RT::Logger->error("object type '$object_type' is incorrect");
1927             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1928             next;
1929         }
1930
1931         my $acls = RT::ACL->new($session{'CurrentUser'});
1932         $acls->LimitToObject( $obj );
1933         $acls->LimitToPrincipal( Id => $principal_id );
1934
1935         while ( my $ace = $acls->Next ) {
1936             my $right = $ace->RightName;
1937
1938             # Has right and should have right
1939             next if delete $state{$tuple}->{$right};
1940
1941             # Has right and shouldn't have right
1942             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
1943             push @results, $msg;
1944         }
1945
1946         # For everything left, they don't have the right but they should
1947         for my $right (keys %{ $state{$tuple} || {} }) {
1948             delete $state{$tuple}->{$right};
1949             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
1950             push @results, $msg;
1951         }
1952
1953         # Check our state for leftovers
1954         if ( keys %{ $state{$tuple} || {} } ) {
1955             my $missed = join '|', %{$state{$tuple} || {}};
1956             $RT::Logger->warn(
1957                "Uh-oh, it looks like we somehow missed a right in "
1958               ."ProcessACLs.  Here's what was leftover: $missed"
1959             );
1960         }
1961     }
1962
1963     return (@results);
1964 }
1965
1966
1967
1968
1969 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1970
1971 @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.
1972
1973 Returns an array of success/failure messages
1974
1975 =cut
1976
1977 sub UpdateRecordObject {
1978     my %args = (
1979         ARGSRef         => undef,
1980         AttributesRef   => undef,
1981         Object          => undef,
1982         AttributePrefix => undef,
1983         @_
1984     );
1985
1986     my $Object  = $args{'Object'};
1987     my @results = $Object->Update(
1988         AttributesRef   => $args{'AttributesRef'},
1989         ARGSRef         => $args{'ARGSRef'},
1990         AttributePrefix => $args{'AttributePrefix'},
1991     );
1992
1993     return (@results);
1994 }
1995
1996
1997
1998 sub ProcessCustomFieldUpdates {
1999     my %args = (
2000         CustomFieldObj => undef,
2001         ARGSRef        => undef,
2002         @_
2003     );
2004
2005     my $Object  = $args{'CustomFieldObj'};
2006     my $ARGSRef = $args{'ARGSRef'};
2007
2008     my @attribs = qw(Name Type Description Queue SortOrder);
2009     my @results = UpdateRecordObject(
2010         AttributesRef => \@attribs,
2011         Object        => $Object,
2012         ARGSRef       => $ARGSRef
2013     );
2014
2015     my $prefix = "CustomField-" . $Object->Id;
2016     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2017         my ( $addval, $addmsg ) = $Object->AddValue(
2018             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2019             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2020             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2021         );
2022         push( @results, $addmsg );
2023     }
2024
2025     my @delete_values
2026         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2027         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2028         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2029
2030     foreach my $id (@delete_values) {
2031         next unless defined $id;
2032         my ( $err, $msg ) = $Object->DeleteValue($id);
2033         push( @results, $msg );
2034     }
2035
2036     my $vals = $Object->Values();
2037     while ( my $cfv = $vals->Next() ) {
2038         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2039             if ( $cfv->SortOrder != $so ) {
2040                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2041                 push( @results, $msg );
2042             }
2043         }
2044     }
2045
2046     return (@results);
2047 }
2048
2049
2050
2051 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2052
2053 Returns an array of results messages.
2054
2055 =cut
2056
2057 sub ProcessTicketBasics {
2058
2059     my %args = (
2060         TicketObj => undef,
2061         ARGSRef   => undef,
2062         @_
2063     );
2064
2065     my $TicketObj = $args{'TicketObj'};
2066     my $ARGSRef   = $args{'ARGSRef'};
2067
2068     my $OrigOwner = $TicketObj->Owner;
2069
2070     # Set basic fields
2071     my @attribs = qw(
2072         Subject
2073         FinalPriority
2074         Priority
2075         TimeEstimated
2076         TimeWorked
2077         TimeLeft
2078         Type
2079         Status
2080         Queue
2081     );
2082
2083     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2084     for my $field (qw(Queue Owner)) {
2085         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2086             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2087             my $temp = $class->new(RT->SystemUser);
2088             $temp->Load( $ARGSRef->{$field} );
2089             if ( $temp->id ) {
2090                 $ARGSRef->{$field} = $temp->id;
2091             }
2092         }
2093     }
2094
2095     # Status isn't a field that can be set to a null value.
2096     # RT core complains if you try
2097     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2098
2099     my @results = UpdateRecordObject(
2100         AttributesRef => \@attribs,
2101         Object        => $TicketObj,
2102         ARGSRef       => $ARGSRef,
2103     );
2104
2105     # We special case owner changing, so we can use ForceOwnerChange
2106     if ( $ARGSRef->{'Owner'}
2107       && $ARGSRef->{'Owner'} !~ /\D/
2108       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2109         my ($ChownType);
2110         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2111             $ChownType = "Force";
2112         }
2113         else {
2114             $ChownType = "Set";
2115         }
2116
2117         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2118         push( @results, $msg );
2119     }
2120
2121     # }}}
2122
2123     return (@results);
2124 }
2125
2126 sub ProcessTicketReminders {
2127     my %args = (
2128         TicketObj => undef,
2129         ARGSRef   => undef,
2130         @_
2131     );
2132
2133     my $Ticket = $args{'TicketObj'};
2134     my $args   = $args{'ARGSRef'};
2135     my @results;
2136
2137     my $reminder_collection = $Ticket->Reminders->Collection;
2138
2139     if ( $args->{'update-reminders'} ) {
2140         while ( my $reminder = $reminder_collection->Next ) {
2141             if (   $reminder->Status ne 'resolved' && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2142                 $Ticket->Reminders->Resolve($reminder);
2143             }
2144             elsif ( $reminder->Status eq 'resolved' && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2145                 $Ticket->Reminders->Open($reminder);
2146             }
2147
2148             if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2149                 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2150             }
2151
2152             if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2153                 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2154             }
2155
2156             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2157                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2158                 $DateObj->Set(
2159                     Format => 'unknown',
2160                     Value  => $args->{ 'Reminder-Due-' . $reminder->id }
2161                 );
2162                 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2163                     $reminder->SetDue( $DateObj->ISO );
2164                 }
2165             }
2166         }
2167     }
2168
2169     if ( $args->{'NewReminder-Subject'} ) {
2170         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2171         $due_obj->Set(
2172           Format => 'unknown',
2173           Value => $args->{'NewReminder-Due'}
2174         );
2175         my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2176             Subject => $args->{'NewReminder-Subject'},
2177             Owner   => $args->{'NewReminder-Owner'},
2178             Due     => $due_obj->ISO
2179         );
2180         push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2181     }
2182     return @results;
2183 }
2184
2185 sub ProcessTicketCustomFieldUpdates {
2186     my %args = @_;
2187     $args{'Object'} = delete $args{'TicketObj'};
2188     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2189
2190     # Build up a list of objects that we want to work with
2191     my %custom_fields_to_mod;
2192     foreach my $arg ( keys %$ARGSRef ) {
2193         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2194             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2195         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2196             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2197         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2198             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2199         }
2200     }
2201
2202     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2203 }
2204
2205 sub ProcessObjectCustomFieldUpdates {
2206     my %args    = @_;
2207     my $ARGSRef = $args{'ARGSRef'};
2208     my @results;
2209
2210     # Build up a list of objects that we want to work with
2211     my %custom_fields_to_mod;
2212     foreach my $arg ( keys %$ARGSRef ) {
2213
2214         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2215         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2216
2217         # For each of those objects, find out what custom fields we want to work with.
2218         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2219     }
2220
2221     # For each of those objects
2222     foreach my $class ( keys %custom_fields_to_mod ) {
2223         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2224             my $Object = $args{'Object'};
2225             $Object = $class->new( $session{'CurrentUser'} )
2226                 unless $Object && ref $Object eq $class;
2227
2228             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2229             unless ( $Object->id ) {
2230                 $RT::Logger->warning("Couldn't load object $class #$id");
2231                 next;
2232             }
2233
2234             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2235                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2236                 $CustomFieldObj->LoadById($cf);
2237                 unless ( $CustomFieldObj->id ) {
2238                     $RT::Logger->warning("Couldn't load custom field #$cf");
2239                     next;
2240                 }
2241                 push @results,
2242                     _ProcessObjectCustomFieldUpdates(
2243                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2244                     Object      => $Object,
2245                     CustomField => $CustomFieldObj,
2246                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2247                     );
2248             }
2249         }
2250     }
2251     return @results;
2252 }
2253
2254 sub _ProcessObjectCustomFieldUpdates {
2255     my %args    = @_;
2256     my $cf      = $args{'CustomField'};
2257     my $cf_type = $cf->Type || '';
2258
2259     # Remove blank Values since the magic field will take care of this. Sometimes
2260     # the browser gives you a blank value which causes CFs to be processed twice
2261     if (   defined $args{'ARGS'}->{'Values'}
2262         && !length $args{'ARGS'}->{'Values'}
2263         && $args{'ARGS'}->{'Values-Magic'} )
2264     {
2265         delete $args{'ARGS'}->{'Values'};
2266     }
2267
2268     my @results;
2269     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2270
2271         # skip category argument
2272         next if $arg eq 'Category';
2273
2274         # and TimeUnits
2275         next if $arg eq 'Value-TimeUnits';
2276
2277         # since http won't pass in a form element with a null value, we need
2278         # to fake it
2279         if ( $arg eq 'Values-Magic' ) {
2280
2281             # We don't care about the magic, if there's really a values element;
2282             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2283             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2284
2285             # "Empty" values does not mean anything for Image and Binary fields
2286             next if $cf_type =~ /^(?:Image|Binary)$/;
2287
2288             $arg = 'Values';
2289             $args{'ARGS'}->{'Values'} = undef;
2290         }
2291
2292         my @values = ();
2293         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2294             @values = @{ $args{'ARGS'}->{$arg} };
2295         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2296             @values = ( $args{'ARGS'}->{$arg} );
2297         } else {
2298             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2299                 if defined $args{'ARGS'}->{$arg};
2300         }
2301         @values = grep length, map {
2302             s/\r+\n/\n/g;
2303             s/^\s+//;
2304             s/\s+$//;
2305             $_;
2306             }
2307             grep defined, @values;
2308
2309         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2310             foreach my $value (@values) {
2311                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2312                     Field => $cf->id,
2313                     Value => $value
2314                 );
2315                 push( @results, $msg );
2316             }
2317         } elsif ( $arg eq 'Upload' ) {
2318             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2319             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2320             push( @results, $msg );
2321         } elsif ( $arg eq 'DeleteValues' ) {
2322             foreach my $value (@values) {
2323                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2324                     Field => $cf,
2325                     Value => $value,
2326                 );
2327                 push( @results, $msg );
2328             }
2329         } elsif ( $arg eq 'DeleteValueIds' ) {
2330             foreach my $value (@values) {
2331                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2332                     Field   => $cf,
2333                     ValueId => $value,
2334                 );
2335                 push( @results, $msg );
2336             }
2337         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2338             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2339
2340             my %values_hash;
2341             foreach my $value (@values) {
2342                 if ( my $entry = $cf_values->HasEntry($value) ) {
2343                     $values_hash{ $entry->id } = 1;
2344                     next;
2345                 }
2346
2347                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2348                     Field => $cf,
2349                     Value => $value
2350                 );
2351                 push( @results, $msg );
2352                 $values_hash{$val} = 1 if $val;
2353             }
2354
2355             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2356             return @results if ( $cf->Type eq 'Date' && ! @values );
2357
2358             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2359             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2360
2361             $cf_values->RedoSearch;
2362             while ( my $cf_value = $cf_values->Next ) {
2363                 next if $values_hash{ $cf_value->id };
2364
2365                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2366                     Field   => $cf,
2367                     ValueId => $cf_value->id
2368                 );
2369                 push( @results, $msg );
2370             }
2371         } elsif ( $arg eq 'Values' ) {
2372             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2373
2374             # keep everything up to the point of difference, delete the rest
2375             my $delete_flag;
2376             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2377                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2378                     shift @values;
2379                     next;
2380                 }
2381
2382                 $delete_flag ||= 1;
2383                 $old_cf->Delete;
2384             }
2385
2386             # now add/replace extra things, if any
2387             foreach my $value (@values) {
2388                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2389                     Field => $cf,
2390                     Value => $value
2391                 );
2392                 push( @results, $msg );
2393             }
2394         } else {
2395             push(
2396                 @results,
2397                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2398                     $cf->Name, ref $args{'Object'},
2399                     $args{'Object'}->id
2400                 )
2401             );
2402         }
2403     }
2404     return @results;
2405 }
2406
2407
2408 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2409
2410 Returns an array of results messages.
2411
2412 =cut
2413
2414 sub ProcessTicketWatchers {
2415     my %args = (
2416         TicketObj => undef,
2417         ARGSRef   => undef,
2418         @_
2419     );
2420     my (@results);
2421
2422     my $Ticket  = $args{'TicketObj'};
2423     my $ARGSRef = $args{'ARGSRef'};
2424
2425     # Munge watchers
2426
2427     foreach my $key ( keys %$ARGSRef ) {
2428
2429         # Delete deletable watchers
2430         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2431             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2432                 PrincipalId => $2,
2433                 Type        => $1
2434             );
2435             push @results, $msg;
2436         }
2437
2438         # Delete watchers in the simple style demanded by the bulk manipulator
2439         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2440             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2441                 Email => $ARGSRef->{$key},
2442                 Type  => $1
2443             );
2444             push @results, $msg;
2445         }
2446
2447         # Add new wathchers by email address
2448         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2449             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2450         {
2451
2452             #They're in this order because otherwise $1 gets clobbered :/
2453             my ( $code, $msg ) = $Ticket->AddWatcher(
2454                 Type  => $ARGSRef->{$key},
2455                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2456             );
2457             push @results, $msg;
2458         }
2459
2460         #Add requestors in the simple style demanded by the bulk manipulator
2461         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2462             my ( $code, $msg ) = $Ticket->AddWatcher(
2463                 Type  => $1,
2464                 Email => $ARGSRef->{$key}
2465             );
2466             push @results, $msg;
2467         }
2468
2469         # Add new  watchers by owner
2470         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2471             my $principal_id = $1;
2472             my $form         = $ARGSRef->{$key};
2473             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2474                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2475
2476                 my ( $code, $msg ) = $Ticket->AddWatcher(
2477                     Type        => $value,
2478                     PrincipalId => $principal_id
2479                 );
2480                 push @results, $msg;
2481             }
2482         }
2483
2484     }
2485     return (@results);
2486 }
2487
2488
2489
2490 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2491
2492 Returns an array of results messages.
2493
2494 =cut
2495
2496 sub ProcessTicketDates {
2497     my %args = (
2498         TicketObj => undef,
2499         ARGSRef   => undef,
2500         @_
2501     );
2502
2503     my $Ticket  = $args{'TicketObj'};
2504     my $ARGSRef = $args{'ARGSRef'};
2505
2506     my (@results);
2507
2508     # Set date fields
2509     my @date_fields = qw(
2510         Told
2511         Resolved
2512         Starts
2513         Started
2514         Due
2515     );
2516
2517     #Run through each field in this list. update the value if apropriate
2518     foreach my $field (@date_fields) {
2519         next unless exists $ARGSRef->{ $field . '_Date' };
2520         next if $ARGSRef->{ $field . '_Date' } eq '';
2521
2522         my ( $code, $msg );
2523
2524         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2525         $DateObj->Set(
2526             Format => 'unknown',
2527             Value  => $ARGSRef->{ $field . '_Date' }
2528         );
2529
2530         my $obj = $field . "Obj";
2531         if (    ( defined $DateObj->Unix )
2532             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2533         {
2534             my $method = "Set$field";
2535             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2536             push @results, "$msg";
2537         }
2538     }
2539
2540     # }}}
2541     return (@results);
2542 }
2543
2544
2545
2546 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2547
2548 Returns an array of results messages.
2549
2550 =cut
2551
2552 sub ProcessTicketLinks {
2553     my %args = (
2554         TicketObj => undef,
2555         ARGSRef   => undef,
2556         @_
2557     );
2558
2559     my $Ticket  = $args{'TicketObj'};
2560     my $ARGSRef = $args{'ARGSRef'};
2561
2562     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2563
2564     #Merge if we need to
2565     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2566         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2567         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2568         push @results, $msg;
2569     }
2570
2571     return (@results);
2572 }
2573
2574
2575 sub ProcessRecordLinks {
2576     my %args = (
2577         RecordObj => undef,
2578         ARGSRef   => undef,
2579         @_
2580     );
2581
2582     my $Record  = $args{'RecordObj'};
2583     my $ARGSRef = $args{'ARGSRef'};
2584
2585     my (@results);
2586
2587     # Delete links that are gone gone gone.
2588     foreach my $arg ( keys %$ARGSRef ) {
2589         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2590             my $base   = $1;
2591             my $type   = $2;
2592             my $target = $3;
2593
2594             my ( $val, $msg ) = $Record->DeleteLink(
2595                 Base   => $base,
2596                 Type   => $type,
2597                 Target => $target
2598             );
2599
2600             push @results, $msg;
2601
2602         }
2603
2604     }
2605
2606     my @linktypes = qw( DependsOn MemberOf RefersTo );
2607
2608     foreach my $linktype (@linktypes) {
2609         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2610             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2611                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2612
2613             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2614                 next unless $luri;
2615                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2616                 my ( $val, $msg ) = $Record->AddLink(
2617                     Target => $luri,
2618                     Type   => $linktype
2619                 );
2620                 push @results, $msg;
2621             }
2622         }
2623         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2624             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2625                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2626
2627             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2628                 next unless $luri;
2629                 my ( $val, $msg ) = $Record->AddLink(
2630                     Base => $luri,
2631                     Type => $linktype
2632                 );
2633
2634                 push @results, $msg;
2635             }
2636         }
2637     }
2638
2639     return (@results);
2640 }
2641
2642 =head2 _UploadedFile ( $arg );
2643
2644 Takes a CGI parameter name; if a file is uploaded under that name,
2645 return a hash reference suitable for AddCustomFieldValue's use:
2646 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2647
2648 Returns C<undef> if no files were uploaded in the C<$arg> field.
2649
2650 =cut
2651
2652 sub _UploadedFile {
2653     my $arg         = shift;
2654     my $cgi_object  = $m->cgi_object;
2655     my $fh          = $cgi_object->upload($arg) or return undef;
2656     my $upload_info = $cgi_object->uploadInfo($fh);
2657
2658     my $filename = "$fh";
2659     $filename =~ s#^.*[\\/]##;
2660     binmode($fh);
2661
2662     return {
2663         Value        => $filename,
2664         LargeContent => do { local $/; scalar <$fh> },
2665         ContentType  => $upload_info->{'Content-Type'},
2666     };
2667 }
2668
2669 sub GetColumnMapEntry {
2670     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2671
2672     # deal with the simplest thing first
2673     if ( $args{'Map'}{ $args{'Name'} } ) {
2674         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2675     }
2676
2677     # complex things
2678     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2679         return undef unless $args{'Map'}->{$mainkey};
2680         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2681             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2682
2683         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2684     }
2685     return undef;
2686 }
2687
2688 sub ProcessColumnMapValue {
2689     my $value = shift;
2690     my %args = ( Arguments => [], Escape => 1, @_ );
2691
2692     if ( ref $value ) {
2693         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2694             my @tmp = $value->( @{ $args{'Arguments'} } );
2695             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2696         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2697             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2698         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2699             return $$value;
2700         }
2701     }
2702
2703     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2704     return $value;
2705 }
2706
2707 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2708
2709 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2710 principal collections mapped from the categories given.
2711
2712 =cut
2713
2714 sub GetPrincipalsMap {
2715     my $object = shift;
2716     my @map;
2717     for (@_) {
2718         if (/System/) {
2719             my $system = RT::Groups->new($session{'CurrentUser'});
2720             $system->LimitToSystemInternalGroups();
2721             $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2722             push @map, [
2723                 'System' => $system,    # loc_left_pair
2724                 'Type'   => 1,
2725             ];
2726         }
2727         elsif (/Groups/) {
2728             my $groups = RT::Groups->new($session{'CurrentUser'});
2729             $groups->LimitToUserDefinedGroups();
2730             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2731
2732             # Only show groups who have rights granted on this object
2733             $groups->WithGroupRight(
2734                 Right   => '',
2735                 Object  => $object,
2736                 IncludeSystemRights => 0,
2737                 IncludeSubgroupMembers => 0,
2738             );
2739
2740             push @map, [
2741                 'User Groups' => $groups,   # loc_left_pair
2742                 'Name'        => 0
2743             ];
2744         }
2745         elsif (/Roles/) {
2746             my $roles = RT::Groups->new($session{'CurrentUser'});
2747
2748             if ($object->isa('RT::System')) {
2749                 $roles->LimitToRolesForSystem();
2750             }
2751             elsif ($object->isa('RT::Queue')) {
2752                 $roles->LimitToRolesForQueue($object->Id);
2753             }
2754             else {
2755                 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
2756                 next;
2757             }
2758             $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2759             push @map, [
2760                 'Roles' => $roles,  # loc_left_pair
2761                 'Type'  => 1
2762             ];
2763         }
2764         elsif (/Users/) {
2765             my $Users = RT->PrivilegedUsers->UserMembersObj();
2766             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2767
2768             # Only show users who have rights granted on this object
2769             my $group_members = $Users->WhoHaveGroupRight(
2770                 Right   => '',
2771                 Object  => $object,
2772                 IncludeSystemRights => 0,
2773                 IncludeSubgroupMembers => 0,
2774             );
2775
2776             # Limit to UserEquiv groups
2777             my $groups = $Users->NewAlias('Groups');
2778             $Users->Join(
2779                 ALIAS1 => $groups,
2780                 FIELD1 => 'id',
2781                 ALIAS2 => $group_members,
2782                 FIELD2 => 'GroupId'
2783             );
2784             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
2785             $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
2786
2787
2788             my $display = sub {
2789                 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
2790             };
2791             push @map, [
2792                 'Users' => $Users,  # loc_left_pair
2793                 $display => 0
2794             ];
2795         }
2796     }
2797     return @map;
2798 }
2799
2800 =head2 _load_container_object ( $type, $id );
2801
2802 Instantiate container object for saving searches.
2803
2804 =cut
2805
2806 sub _load_container_object {
2807     my ( $obj_type, $obj_id ) = @_;
2808     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2809 }
2810
2811 =head2 _parse_saved_search ( $arg );
2812
2813 Given a serialization string for saved search, and returns the
2814 container object and the search id.
2815
2816 =cut
2817
2818 sub _parse_saved_search {
2819     my $spec = shift;
2820     return unless $spec;
2821     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2822         return;
2823     }
2824     my $obj_type  = $1;
2825     my $obj_id    = $2;
2826     my $search_id = $3;
2827
2828     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2829 }
2830
2831 =head2 ScrubHTML content
2832
2833 Removes unsafe and undesired HTML from the passed content
2834
2835 =cut
2836
2837 my $SCRUBBER;
2838 sub ScrubHTML {
2839     my $Content = shift;
2840     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2841
2842     $Content = '' if !defined($Content);
2843     return $SCRUBBER->scrub($Content);
2844 }
2845
2846 =head2 _NewScrubber
2847
2848 Returns a new L<HTML::Scrubber> object.  Override this if you insist on
2849 letting more HTML through.
2850
2851 =cut
2852
2853 sub _NewScrubber {
2854     require HTML::Scrubber;
2855     my $scrubber = HTML::Scrubber->new();
2856     $scrubber->default(
2857         0,
2858         {
2859             '*'    => 0,
2860             id     => 1,
2861             class  => 1,
2862             # Match http, ftp and relative urls
2863             # XXX: we also scrub format strings with this module then allow simple config options
2864             href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2865             face   => 1,
2866             size   => 1,
2867             target => 1,
2868             style  => qr{
2869                 ^(?:\s*
2870                     (?:(?:background-)?color: \s*
2871                             (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
2872                                \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
2873                                [\w\-]+                                  # green, light-blue, etc.
2874                                )                            |
2875                        text-align: \s* \w+                  |
2876                        font-size: \s* [\w.\-]+              |
2877                        font-family: \s* [\w\s"',.\-]+       |
2878                        font-weight: \s* [\w\-]+             |
2879
2880                        # MS Office styles, which are probably fine.  If we don't, then any
2881                        # associated styles in the same attribute get stripped.
2882                        mso-[\w\-]+?: \s* [\w\s"',.\-]+
2883                     )\s* ;? \s*)
2884                  +$ # one or more of these allowed properties from here 'till sunset
2885             }ix,
2886         }
2887     );
2888     $scrubber->deny(qw[*]);
2889     $scrubber->allow(
2890         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]
2891     );
2892     $scrubber->comment(0);
2893
2894     return $scrubber;
2895 }
2896
2897 =head2 JSON
2898
2899 Redispatches to L<RT::Interface::Web/EncodeJSON>
2900
2901 =cut
2902
2903 sub JSON {
2904     RT::Interface::Web::EncodeJSON(@_);
2905 }
2906
2907 package RT::Interface::Web;
2908 RT::Base->_ImportOverlays();
2909
2910 1;