diff options
Diffstat (limited to 'rt/lib/RT/Interface')
| -rw-r--r-- | rt/lib/RT/Interface/CLI.pm | 48 | ||||
| -rwxr-xr-x | rt/lib/RT/Interface/Email.pm | 174 | ||||
| -rwxr-xr-x | rt/lib/RT/Interface/Email/Auth/GnuPG.pm | 12 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Email/Auth/MailFrom.pm | 13 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Email/Filter/SpamAssassin.pm | 97 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/REST.pm | 21 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web.pm | 1143 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Handler.pm | 230 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Menu.pm | 259 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Menu/Item.pm | 88 | ||||
| -rwxr-xr-x | rt/lib/RT/Interface/Web/QueryBuilder.pm | 2 | ||||
| -rwxr-xr-x | rt/lib/RT/Interface/Web/QueryBuilder/Tree.pm | 24 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Request.pm | 51 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Session.pm | 2 | ||||
| -rwxr-xr-x | rt/lib/RT/Interface/Web/Standalone.pm | 126 | ||||
| -rw-r--r-- | rt/lib/RT/Interface/Web/Standalone/PreFork.pm | 103 |
16 files changed, 1560 insertions, 833 deletions
diff --git a/rt/lib/RT/Interface/CLI.pm b/rt/lib/RT/Interface/CLI.pm index fe109d02a..bcdc13cdf 100644 --- a/rt/lib/RT/Interface/CLI.pm +++ b/rt/lib/RT/Interface/CLI.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -46,25 +46,12 @@ # # END BPS TAGGED BLOCK }}} +package RT::Interface::CLI; use strict; - use RT; -package RT::Interface::CLI; - - -BEGIN { - use base 'Exporter'; - use vars qw ($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); - - # set the version for version checking - $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker - - # your exported package globals go here, - # as well as any optionally exported functions - @EXPORT_OK = qw(&CleanEnv - &GetCurrentUser &GetMessageContent &debug &loc); -} +use base 'Exporter'; +our @EXPORT_OK = qw(CleanEnv GetCurrentUser GetMessageContent debug loc); =head1 NAME @@ -124,7 +111,6 @@ sub CleanEnv { my $CurrentUser; # shared betwen GetCurrentUser and loc -# {{{ sub GetCurrentUser =head2 GetCurrentUser @@ -144,7 +130,7 @@ sub GetCurrentUser { #If the current user is 0, then RT will assume that the User object #is that of the currentuser. - $CurrentUser = new RT::CurrentUser(); + $CurrentUser = RT::CurrentUser->new(); $CurrentUser->LoadByGecos($Gecos); unless ($CurrentUser->Id) { @@ -153,10 +139,8 @@ sub GetCurrentUser { return($CurrentUser); } -# }}} -# {{{ sub loc =head2 loc @@ -168,12 +152,10 @@ sub loc { die "No current user yet" unless $CurrentUser ||= RT::CurrentUser->new; return $CurrentUser->loc(@_); } -# }}} } -# {{{ sub GetMessageContent =head2 GetMessageContent @@ -200,7 +182,7 @@ sub GetMessageContent { #Load the sourcefile, if it's been handed to us if ($source) { - open( SOURCE, '<', $source ) or die $!; + open( SOURCE, '<', $source ) or die $!; @lines = (<SOURCE>) or die $!; close (SOURCE) or die $!; } @@ -235,9 +217,7 @@ sub GetMessageContent { } -# }}} -# {{{ sub debug sub debug { my $val = shift; @@ -253,8 +233,20 @@ sub debug { } } -# }}} - +sub ShowHelp { + my $self = shift; + my %args = @_; + require Pod::Usage; + Pod::Usage::pod2usage( + -message => $args{'Message'}, + -exitval => $args{'ExitValue'} || 0, + -verbose => 99, + -sections => $args{'Sections'} || ($args{'ExitValue'} + ? 'NAME|USAGE' + : 'NAME|USAGE|OPTIONS|DESCRIPTION' + ), + ); +} RT::Base->_ImportOverlays(); diff --git a/rt/lib/RT/Interface/Email.pm b/rt/lib/RT/Interface/Email.pm index 9216887cd..02a1ec0c0 100755 --- a/rt/lib/RT/Interface/Email.pm +++ b/rt/lib/RT/Interface/Email.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -57,6 +57,7 @@ use RT::EmailParser; use File::Temp; use UNIVERSAL::require; use Mail::Mailer (); +use Text::ParseWords qw/shellwords/; BEGIN { use base 'Exporter'; @@ -387,7 +388,7 @@ sub SendEmail { unless ( $args{'Entity'}->head->get('Date') ) { require RT::Date; - my $date = RT::Date->new( $RT::SystemUser ); + my $date = RT::Date->new( RT->SystemUser ); $date->SetToNow; $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) ); } @@ -404,10 +405,12 @@ sub SendEmail { if ( $mail_command eq 'sendmailpipe' ) { my $path = RT->Config->Get('SendmailPath'); - my $args = RT->Config->Get('SendmailArguments'); + my @args = shellwords(RT->Config->Get('SendmailArguments')); - # SetOutgoingMailFrom - if ( RT->Config->Get('SetOutgoingMailFrom') ) { + # SetOutgoingMailFrom and bounces conflict, since they both want -f + if ( $args{'Bounce'} ) { + push @args, shellwords(RT->Config->Get('SendmailBounceArguments')); + } elsif ( RT->Config->Get('SetOutgoingMailFrom') ) { my $OutgoingMailAddress; if ($TicketObj) { @@ -423,13 +426,10 @@ sub SendEmail { $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'}; - $args .= " -f $OutgoingMailAddress" + push @args, "-f", $OutgoingMailAddress if $OutgoingMailAddress; } - # Set Bounce Arguments - $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'}; - # VERP if ( $TransactionObj and my $prefix = RT->Config->Get('VERPPrefix') and @@ -438,32 +438,36 @@ sub SendEmail { my $from = $TransactionObj->CreatorObj->EmailAddress; $from =~ s/@/=/g; $from =~ s/\s//g; - $args .= " -f $prefix$from\@$domain"; + push @args, "-f", "$prefix$from\@$domain"; } eval { # don't ignore CHLD signal to get proper exit code local $SIG{'CHLD'} = 'DEFAULT'; - open( my $mail, '|-', "$path $args >/dev/null" ) - or die "couldn't execute program: $!"; - # if something wrong with $mail->print we will get PIPE signal, handle it local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" }; + + require IPC::Open2; + my ($mail, $stdout); + my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args ) + or die "couldn't execute program: $!"; + $args{'Entity'}->print($mail); + close $mail or die "close pipe failed: $!"; - unless ( close $mail ) { - die "close pipe failed: $!" if $!; # system error + waitpid($pid, 0); + if ($?) { # sendmail exit statuses mostly errors with data not software # TODO: status parsing: core dump, exit on signal or EX_* - my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8); + my $msg = "$msgid: `$path @args` exited with code ". ($?>>8); $msg = ", interrupted by signal ". ($?&127) if $?&127; $RT::Logger->error( $msg ); die $msg; } }; if ( $@ ) { - $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ ); + $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ ); if ( $TicketObj ) { _RecordSendEmailFailure( $TicketObj ); } @@ -555,7 +559,7 @@ sub PrepareEmailUsingTemplate { @_ ); - my $template = RT::Template->new( $RT::SystemUser ); + my $template = RT::Template->new( RT->SystemUser ); $template->LoadGlobalTemplate( $args{'Template'} ); unless ( $template->id ) { return (undef, "Couldn't load template '". $args{'Template'} ."'"); @@ -583,6 +587,7 @@ sub SendEmailUsingTemplate { Bcc => undef, From => RT->Config->Get('CorrespondAddress'), InReplyTo => undef, + ExtraHeaders => {}, @_ ); @@ -598,6 +603,9 @@ sub SendEmailUsingTemplate { $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) ) foreach grep defined $args{$_}, qw(To Cc Bcc From); + $mail->head->set( $_ => $args{ExtraHeaders}{$_} ) + foreach keys %{ $args{ExtraHeaders} }; + SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} ); return SendEmail( Entity => $mail ); @@ -615,7 +623,19 @@ sub ForwardTransaction { my $entity = $txn->ContentAsMIME; - return SendForward( %args, Entity => $entity, Transaction => $txn ); + my ( $ret, $msg ) = SendForward( %args, Entity => $entity, Transaction => $txn ); + if ($ret) { + my $ticket = $txn->TicketObj; + my ( $ret, $msg ) = $ticket->_NewTransaction( + Type => 'Forward Transaction', + Field => $txn->id, + Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc}, + ); + unless ($ret) { + $RT::Logger->error("Failed to create transaction: $msg"); + } + } + return ( $ret, $msg ); } =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => '' @@ -635,13 +655,33 @@ sub ForwardTicket { ) for qw(Create Correspond); my $entity = MIME::Entity->build( - Type => 'multipart/mixed', + Type => 'multipart/mixed', + Description => 'forwarded ticket', ); $entity->add_part( $_ ) foreach map $_->ContentAsMIME, @{ $txns->ItemsArrayRef }; - return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' ); + my ( $ret, $msg ) = SendForward( + %args, + Entity => $entity, + Ticket => $ticket, + Template => 'Forward Ticket', + ); + + if ($ret) { + my ( $ret, $msg ) = $ticket->_NewTransaction( + Type => 'Forward Ticket', + Field => $ticket->id, + Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc}, + ); + unless ($ret) { + $RT::Logger->error("Failed to create transaction: $msg"); + } + } + + return ( $ret, $msg ); + } =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => '' @@ -704,34 +744,55 @@ sub SendForward { $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) ) foreach grep defined $args{$_}, qw(To Cc Bcc); - $mail->attach( - Type => 'message/rfc822', - Disposition => 'attachment', - Description => 'forwarded message', - Data => $entity->as_string, - ); + $mail->make_multipart unless $mail->is_multipart; + $mail->add_part( $entity ); my $from; - my $subject = ''; - $subject = $txn->Subject if $txn; - $subject ||= $ticket->Subject if $ticket; - if ( RT->Config->Get('ForwardFromUser') ) { - $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress; - } else { - # XXX: what if want to forward txn of other object than ticket? - $subject = AddSubjectTag( $subject, $ticket ); - $from = $ticket->QueueObj->CorrespondAddress - || RT->Config->Get('CorrespondAddress'); + unless (defined $mail->head->get('Subject')) { + my $subject = ''; + $subject = $txn->Subject if $txn; + $subject ||= $ticket->Subject if $ticket; + + unless ( RT->Config->Get('ForwardFromUser') ) { + # XXX: what if want to forward txn of other object than ticket? + $subject = AddSubjectTag( $subject, $ticket ); + } + + $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) ); } - $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) ); - $mail->head->set( From => EncodeToMIME( String => $from ) ); + + $mail->head->set( + From => EncodeToMIME( + String => GetForwardFrom( Transaction => $txn, Ticket => $ticket ) + ) + ); my $status = RT->Config->Get('ForwardFromUser') # never sign if we forward from User ? SendEmail( %args, Entity => $mail, Sign => 0 ) : SendEmail( %args, Entity => $mail ); return (0, $ticket->loc("Couldn't send email")) unless $status; - return (1, $ticket->loc("Send email successfully")); + return (1, $ticket->loc("Sent email successfully")); +} + +=head2 GetForwardFrom Ticket => undef, Transaction => undef + +Resolve the From field to use in forward mail + +=cut + +sub GetForwardFrom { + my %args = ( Ticket => undef, Transaction => undef, @_ ); + my $txn = $args{Transaction}; + my $ticket = $args{Ticket} || $txn->Object; + + if ( RT->Config->Get('ForwardFromUser') ) { + return ( $txn || $ticket )->CurrentUser->UserObj->EmailAddress; + } + else { + return $ticket->QueueObj->CorrespondAddress + || RT->Config->Get('CorrespondAddress'); + } } =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0 @@ -891,7 +952,7 @@ sub EncodeToMIME { return ($value); } - return ($value) unless $value =~ /[^\x20-\x7e]/; + return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s; $value =~ s/\s+$//; @@ -920,7 +981,7 @@ sub EncodeToMIME { sub CreateUser { my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_; - my $NewUser = RT::User->new( $RT::SystemUser ); + my $NewUser = RT::User->new( RT->SystemUser ); my ( $Val, $Message ) = $NewUser->Create( Name => ( $Username || $Address ), @@ -955,7 +1016,7 @@ sub CreateUser { } #Load the new user object - my $CurrentUser = new RT::CurrentUser; + my $CurrentUser = RT::CurrentUser->new; $CurrentUser->LoadByEmail( $Address ); unless ( $CurrentUser->id ) { @@ -1087,12 +1148,7 @@ sub ParseAddressFromHeader { return ( undef, undef ); } - my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address ); - - #Lets take the from and load a user object. - my $Address = $AddrObj->address; - - return ( $Address, $Name ); + return ( $AddrObj->address, $AddrObj->phrase ); } =head2 DeleteRecipientsFromHead HEAD RECIPIENTS @@ -1195,7 +1251,7 @@ sub AddSubjectTag { my $subject = shift; my $ticket = shift; unless ( ref $ticket ) { - my $tmp = RT::Ticket->new( $RT::SystemUser ); + my $tmp = RT::Ticket->new( RT->SystemUser ); $tmp->Load( $ticket ); $ticket = $tmp; } @@ -1211,7 +1267,7 @@ sub AddSubjectTag { } return $subject if $subject =~ /\[$tag_re\s+#$id\]/; - $subject =~ s/(\r\n|\n|\s)/ /gi; + $subject =~ s/(\r\n|\n|\s)/ /g; chomp $subject; return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject"; } @@ -1263,7 +1319,7 @@ sub _LoadPlugins { } elsif ( !ref $plugin ) { my $Class = $plugin; $Class = "RT::Interface::Email::" . $Class - unless $Class =~ /^RT::Interface::Email::/; + unless $Class =~ /^RT::/; $Class->require or do { $RT::Logger->error("Couldn't load $Class: $@"); next }; @@ -1375,7 +1431,7 @@ sub Gateway { my $Subject = $head->get('Subject') || ''; chomp $Subject; - # {{{ Lets check for mail loops of various sorts. + # Lets check for mail loops of various sorts. my ($should_store_machine_generated_message, $IsALoop, $result); ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) = _HandleMachineGeneratedMail( @@ -1394,7 +1450,7 @@ sub Gateway { $args{'ticket'} ||= ParseTicketId( $Subject ); - $SystemTicket = RT::Ticket->new( $RT::SystemUser ); + $SystemTicket = RT::Ticket->new( RT->SystemUser ); $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ; if ( $SystemTicket->id ) { $Right = 'ReplyToTicket'; @@ -1403,7 +1459,7 @@ sub Gateway { } #Set up a queue object - my $SystemQueueObj = RT::Queue->new( $RT::SystemUser ); + my $SystemQueueObj = RT::Queue->new( RT->SystemUser ); $SystemQueueObj->Load( $args{'queue'} ); # We can safely have no queue of we have a known-good ticket @@ -1420,7 +1476,7 @@ sub Gateway { SystemQueue => $SystemQueueObj, ); - # {{{ If authentication fails and no new user was created, get out. + # If authentication fails and no new user was created, get out. if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) { # If the plugins refused to create one, they lose. @@ -1772,7 +1828,7 @@ sub _HandleMachineGeneratedMail { # Squelch replies if necessary # Don't let the user stuff the RT-Squelch-Replies-To header. if ( $head->get('RT-Squelch-Replies-To') ) { - $head->add( + $head->replace( 'RT-Relocated-Squelch-Replies-To', $head->get('RT-Squelch-Replies-To') ); @@ -1787,8 +1843,8 @@ sub _HandleMachineGeneratedMail { # to the scrip. We might want to notify nobody. Or just # the RT Owner. Or maybe all Privileged watchers. my ( $Sender, $junk ) = ParseSenderAddressFromHead($head); - $head->add( 'RT-Squelch-Replies-To', $Sender ); - $head->add( 'RT-DetectedAutoGenerated', 'true' ); + $head->replace( 'RT-Squelch-Replies-To', $Sender ); + $head->replace( 'RT-DetectedAutoGenerated', 'true' ); } return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop ); } diff --git a/rt/lib/RT/Interface/Email/Auth/GnuPG.pm b/rt/lib/RT/Interface/Email/Auth/GnuPG.pm index 6d43b9610..e508908fb 100755 --- a/rt/lib/RT/Interface/Email/Auth/GnuPG.pm +++ b/rt/lib/RT/Interface/Email/Auth/GnuPG.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -58,7 +58,7 @@ To use the gnupg-secured mail gateway, you need to do the following: Set up a GnuPG key directory with a pubring containing only the keys you care about and specify the following in your SiteConfig.pm - Set(%GnuPGOptions, homedir => '/opt/rt3/var/data/GnuPG'); + Set(%GnuPGOptions, homedir => '/opt/rt4/var/data/GnuPG'); Set(@MailPlugins, 'Auth::MailFrom', 'Auth::GnuPG', ...other filter...); =cut @@ -88,7 +88,7 @@ sub GetCurrentUser { Entity => $args{'Message'}, AddStatus => 1, ); if ( $status && !@res ) { - $args{'Message'}->head->add( + $args{'Message'}->head->replace( 'X-RT-Incoming-Encryption' => 'Not encrypted' ); @@ -112,7 +112,7 @@ sub GetCurrentUser { Data => ${ $args{'RawMessageRef'} }, ); - $args{'Message'}->head->add( 'X-RT-Privacy' => 'PGP' ); + $args{'Message'}->head->replace( 'X-RT-Privacy' => 'PGP' ); foreach my $part ( $args{'Message'}->parts_DFS ) { my $decrypted; @@ -124,14 +124,14 @@ sub GetCurrentUser { $decrypted = 1; } if ( $_->{Operation} eq 'Verify' && $_->{Status} eq 'DONE' ) { - $part->head->add( + $part->head->replace( 'X-RT-Incoming-Signature' => $_->{UserString} ); } } } - $part->head->add( + $part->head->replace( 'X-RT-Incoming-Encryption' => $decrypted ? 'Success' : 'Not encrypted' ); diff --git a/rt/lib/RT/Interface/Email/Auth/MailFrom.pm b/rt/lib/RT/Interface/Email/Auth/MailFrom.pm index be2f517e1..e733bdaae 100644 --- a/rt/lib/RT/Interface/Email/Auth/MailFrom.pm +++ b/rt/lib/RT/Interface/Email/Auth/MailFrom.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -47,10 +47,12 @@ # END BPS TAGGED BLOCK }}} package RT::Interface::Email::Auth::MailFrom; -use RT::Interface::Email qw(ParseSenderAddressFromHead CreateUser); + use strict; use warnings; +use RT::Interface::Email qw(ParseSenderAddressFromHead CreateUser); + # This is what the ordinary, non-enhanced gateway does at the moment. sub GetCurrentUser { @@ -70,7 +72,7 @@ sub GetCurrentUser { return ( $args{'CurrentUser'}, -1 ); } - my $CurrentUser = new RT::CurrentUser; + my $CurrentUser = RT::CurrentUser->new; $CurrentUser->LoadByEmail( $Address ); $CurrentUser->LoadByName( $Address ) unless $CurrentUser->Id; if ( $CurrentUser->Id ) { @@ -79,14 +81,13 @@ sub GetCurrentUser { } # If the user can't be loaded, we may need to create one. Figure out the acl situation. - my $unpriv = RT::Group->new( $RT::SystemUser ); - $unpriv->LoadSystemInternalGroup('Unprivileged'); + my $unpriv = RT->UnprivilegedUsers(); unless ( $unpriv->Id ) { $RT::Logger->crit("Couldn't find the 'Unprivileged' internal group"); return ( $args{'CurrentUser'}, -1 ); } - my $everyone = RT::Group->new( $RT::SystemUser ); + my $everyone = RT::Group->new( RT->SystemUser ); $everyone->LoadSystemInternalGroup('Everyone'); unless ( $everyone->Id ) { $RT::Logger->crit("Couldn't find the 'Everyone' internal group"); diff --git a/rt/lib/RT/Interface/Email/Filter/SpamAssassin.pm b/rt/lib/RT/Interface/Email/Filter/SpamAssassin.pm deleted file mode 100644 index 0470e6340..000000000 --- a/rt/lib/RT/Interface/Email/Filter/SpamAssassin.pm +++ /dev/null @@ -1,97 +0,0 @@ -# BEGIN BPS TAGGED BLOCK {{{ -# -# COPYRIGHT: -# -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC -# <sales@bestpractical.com> -# -# (Except where explicitly superseded by other copyright notices) -# -# -# LICENSE: -# -# This work is made available to you under the terms of Version 2 of -# the GNU General Public License. A copy of that license should have -# been provided with this software, but in any event can be snarfed -# from www.gnu.org. -# -# This work is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -# 02110-1301 or visit their web page on the internet at -# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. -# -# -# CONTRIBUTION SUBMISSION POLICY: -# -# (The following paragraph is not intended to limit the rights granted -# to you to modify and distribute this software under the terms of -# the GNU General Public License and is only of importance to you if -# you choose to contribute your changes and enhancements to the -# community by submitting them to Best Practical Solutions, LLC.) -# -# By intentionally submitting any modifications, corrections or -# derivatives to this work, or any other work intended for use with -# Request Tracker, to Best Practical Solutions, LLC, you confirm that -# you are the copyright holder for those contributions and you grant -# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, -# royalty-free, perpetual, license to use, copy, create derivative -# works based on those contributions, and sublicense and distribute -# those contributions and any derivatives thereof. -# -# END BPS TAGGED BLOCK }}} - -package RT::Interface::Email::Filter::SpamAssassin; -use strict; -use warnings; - -use Mail::SpamAssassin; -my $spamtest = Mail::SpamAssassin->new(); - -sub GetCurrentUser { - my %args = ( - Message => undef, - CurrentUser => undef, - AuthLevel => undef, - @_ - ); - my $status = $spamtest->check( $args{'Message'} ); - return ( $args{'CurrentUser'}, $args{'AuthLevel'} ) - unless $status->is_spam(); - - eval { $status->rewrite_mail() }; - if ( $status->get_hits > $status->get_required_hits() * 1.5 ) { - - # Spammy indeed - return ( $args{'CurrentUser'}, -1 ); - } - return ( $args{'CurrentUser'}, $args{'AuthLevel'} ); - -} - -=head1 NAME - -RT::Interface::Email::Filter::SpamAssassin - Spam filter for RT - -=head1 SYNOPSIS - - # in RT config - Set(@MailPlugins, 'Filter::SpamAssassin', ...other filters...); - -=head1 DESCRIPTION - -This plugin checks to see if an incoming mail is spam (using -C<spamassassin>) and if so, rewrites its headers. If the mail is very -definitely spam - 1.5x more hits than required - then it is dropped on -the floor; otherwise, it is passed on as normal. - -=cut - -RT::Base->_ImportOverlays(); - -1; diff --git a/rt/lib/RT/Interface/REST.pm b/rt/lib/RT/Interface/REST.pm index 7f6c9ac54..aed8f39a2 100644 --- a/rt/lib/RT/Interface/REST.pm +++ b/rt/lib/RT/Interface/REST.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -46,22 +46,13 @@ # # END BPS TAGGED BLOCK }}} -# lib/RT/Interface/REST.pm -# - package RT::Interface::REST; use strict; use warnings; use RT; -BEGIN { - use base 'Exporter'; - use vars qw($VERSION @EXPORT); - - $VERSION = do { my @r = (q$Revision: 1.1.1.10 $ =~ /\d+/g); sprintf "%d."."%02d"x$#r, @r }; - - @EXPORT = qw(expand_list form_parse form_compose vpush vsplit); -} +use base 'Exporter'; +our @EXPORT = qw(expand_list form_parse form_compose vpush vsplit); sub custom_field_spec { my $self = shift; @@ -200,7 +191,7 @@ sub form_parse { # Returns text representing a set of forms. sub form_compose { my ($forms) = @_; - my (@text, $form); + my (@text); foreach my $form (@$forms) { my ($c, $o, $k, $e) = @$form; @@ -214,10 +205,10 @@ sub form_compose { $text .= $e; } elsif ($o) { - my (@lines, $key); + my (@lines); foreach my $key (@$o) { - my ($line, $sp, $v); + my ($line, $sp); my @values = (ref $k->{$key} eq 'ARRAY') ? @{ $k->{$key} } : $k->{$key}; diff --git a/rt/lib/RT/Interface/Web.pm b/rt/lib/RT/Interface/Web.pm index e4167e4cc..262aeacde 100644 --- a/rt/lib/RT/Interface/Web.pm +++ b/rt/lib/RT/Interface/Web.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -65,11 +65,52 @@ package RT::Interface::Web; use RT::SavedSearches; use URI qw(); +use RT::Interface::Web::Menu; use RT::Interface::Web::Session; use Digest::MD5 (); use Encode qw(); +use List::MoreUtils qw(); +use JSON qw(); -# {{{ EscapeUTF8 +=head2 SquishedCSS $style + +=cut + +my %SQUISHED_CSS; +sub SquishedCSS { + my $style = shift or die "need name"; + return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style}; + require RT::Squish::CSS; + my $css = RT::Squish::CSS->new( Style => $style ); + $SQUISHED_CSS{ $css->Style } = $css; + return $css; +} + +=head2 SquishedJS + +=cut + +my $SQUISHED_JS; +sub SquishedJS { + return $SQUISHED_JS if $SQUISHED_JS; + + require RT::Squish::JS; + my $js = RT::Squish::JS->new(); + $SQUISHED_JS = $js; + return $js; +} + +=head2 ClearSquished + +Removes the cached CSS and JS entries, forcing them to be regenerated +on next use. + +=cut + +sub ClearSquished { + undef $SQUISHED_JS; + %SQUISHED_CSS = (); +} =head2 EscapeUTF8 SCALARREF @@ -90,9 +131,7 @@ sub EscapeUTF8 { $$ref =~ s/'/'/g; } -# }}} -# {{{ EscapeURI =head2 EscapeURI SCALARREF @@ -108,9 +147,35 @@ sub EscapeURI { $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg; } -# }}} +=head2 EncodeJSON SCALAR + +Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple +value or a reference. + +=cut + +sub EncodeJSON { + JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 }); +} + +sub _encode_surrogates { + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); +} + +sub EscapeJS { + my $ref = shift; + return unless defined $$ref; -# {{{ WebCanonicalizeInfo + $$ref = "'" . join('', + map { + chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) : + $_ <= 255 ? sprintf("\\x%02X", $_) : + $_ <= 65535 ? sprintf("\\u%04X", $_) : + sprintf("\\u%X\\u%X", _encode_surrogates($_)) + } unpack('U*', $$ref)) + . "'"; +} =head2 WebCanonicalizeInfo(); @@ -124,9 +189,7 @@ sub WebCanonicalizeInfo { return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'}; } -# }}} -# {{{ WebExternalAutoInfo =head2 WebExternalAutoInfo($user); @@ -163,17 +226,21 @@ sub WebExternalAutoInfo { return {%user_info}; } -# }}} sub HandleRequest { my $ARGS = shift; + if (RT->Config->Get('DevelMode')) { + require Module::Refresh; + Module::Refresh->refresh; + } + $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8"); $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ]; # Roll back any dangling transactions from a previous failed connection - $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth; + $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth; MaybeEnableSQLStatementLog(); @@ -183,9 +250,13 @@ sub HandleRequest { $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') ) if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') ); + ValidateWebConfig(); + DecodeARGS($ARGS); + local $HTML::Mason::Commands::DECODED_ARGS = $ARGS; PreprocessTimeUpdates($ARGS); + InitializeMenu(); MaybeShowInstallModePage(); $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS ); @@ -235,6 +306,8 @@ sub HandleRequest { } } + MaybeShowInterstitialCSRFPage($ARGS); + # now it applies not only to home page, but any dashboard that can be used as a workspace $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'} if ( $ARGS->{'HomeRefreshInterval'} ); @@ -243,10 +316,16 @@ sub HandleRequest { $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' ); ShowRequestedPage($ARGS); - LogRecordedSQLStatements(); + LogRecordedSQLStatements(RequestData => { + Path => $HTML::Mason::Commands::m->request_comp->path, + }); # Process per-page final cleanup callbacks $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' ); + + $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS ) + unless $HTML::Mason::Commands::r->content_type + =~ qr<^(text|application)/(x-)?(css|javascript)>; } sub _ForceLogout { @@ -291,8 +370,6 @@ sub SetNextPage { $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next; $HTML::Mason::Commands::session{'i'}++; - - SendSessionCookie(); return $hash; } @@ -409,7 +486,6 @@ sub MaybeShowNoAuthPage { if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn(); # If it's a noauth file, don't ask for auth. - SendSessionCookie(); $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); $m->abort; } @@ -436,7 +512,7 @@ sub MaybeRejectPrivateComponentRequest { _elements | # mobile UI Widgets | autohandler | # requesting this directly is suspicious - l ) # loc component + l (_unsafe)? ) # loc component ( $ | / ) # trailing slash or end of path }xi && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi @@ -449,6 +525,14 @@ sub MaybeRejectPrivateComponentRequest { return; } +sub InitializeMenu { + $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new()); + $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new()); + $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new()); + +} + + =head2 ShowRequestedPage \%ARGS This function, called exclusively by RT's autohandler, dispatches @@ -462,8 +546,13 @@ sub ShowRequestedPage { my $m = $HTML::Mason::Commands::m; + # Ensure that the cookie that we send is up-to-date, in case the + # session-id has been modified in any way SendSessionCookie(); + # precache all system level rights for the current user + $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System ); + # If the user isn't privileged, they can only see SelfService unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) { @@ -509,6 +598,7 @@ sub AttemptExternalAuth { $user =~ s/^\Q$NodeName\E\\//i; } + my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''}; InstantiateNewSession() unless _UserLoggedIn; $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user); @@ -516,7 +606,7 @@ sub AttemptExternalAuth { if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) { # Create users on-the-fly - my $UserObj = RT::User->new($RT::SystemUser); + my $UserObj = RT::User->new(RT->SystemUser); my ( $val, $msg ) = $UserObj->Create( %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} }, Name => $user, @@ -556,6 +646,15 @@ sub AttemptExternalAuth { if ( _UserLoggedIn() ) { $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' ); + # It is possible that we did a redirect to the login page, + # if the external auth allows lack of auth through with no + # REMOTE_USER set, instead of forcing a "permission + # denied" message. Honor the $next. + Redirect($next) if $next; + # Unlike AttemptPasswordAuthentication below, we do not + # force a redirect to / if $next is not set -- otherwise, + # straight-up external auth would always redirect to / + # when you first hit it. } else { delete $HTML::Mason::Commands::session{'CurrentUser'}; $user = $orig_user; @@ -602,7 +701,6 @@ sub AttemptPasswordAuthentication { InstantiateNewSession(); $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj; - SendSessionCookie(); $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' ); @@ -657,6 +755,7 @@ sub LoadSessionFromCookie { sub InstantiateNewSession { tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session); tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef; + SendSessionCookie(); } sub SendSessionCookie { @@ -696,7 +795,7 @@ sub Redirect { # If the user is coming in via a non-canonical # hostname, don't redirect them to the canonical host, # it will just upset them (and invalidate their credentials) - # don't do this if $RT::CanoniaclRedirectURLs is true + # don't do this if $RT::CanonicalizeRedirectURLs is true if ( !RT->Config->Get('CanonicalizeRedirectURLs') && $uri->host eq $server_uri->host && $uri->port eq $server_uri->port ) @@ -708,7 +807,7 @@ sub Redirect { } # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST - $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} ); + $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'}); $uri->port( $ENV{'SERVER_PORT'} ); } @@ -733,11 +832,15 @@ This routine could really use _accurate_ heuristics. (XXX TODO) =cut sub StaticFileHeaders { - my $date = RT::Date->new($RT::SystemUser); + my $date = RT::Date->new(RT->SystemUser); # make cache public $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public'; + # remove any cookie headers -- if it is cached publicly, it + # shouldn't include anyone's cookie! + delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'}; + # Expire things in a month. $date->Set( Value => time + 30 * 24 * 60 * 60 ); $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616; @@ -749,6 +852,22 @@ sub StaticFileHeaders { # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616; } +=head2 ComponentPathIsSafe PATH + +Takes C<PATH> and returns a boolean indicating that the user-specified partial +component path is safe. + +Currently "safe" means that the path does not start with a dot (C<.>) and does +not contain a slash-dot C</.>. + +=cut + +sub ComponentPathIsSafe { + my $self = shift; + my $path = shift; + return $path !~ m{(?:^|/)\.}; +} + =head2 PathIsSafe Takes a C<< Path => path >> and returns a boolean indicating that @@ -834,13 +953,6 @@ sub SendStaticFile { } $type ||= "application/octet-stream"; } - - # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS - # since we don't specify a charset - if ( $type =~ m{application/javascript} && - $type !~ m{charset=([\w-]+)$} ) { - $type .= "; charset=utf-8"; - } $HTML::Mason::Commands::r->content_type($type); open( my $fh, '<', $file ) or die "couldn't open file: $!"; binmode($fh); @@ -852,6 +964,21 @@ sub SendStaticFile { close $fh; } + + +sub MobileClient { + my $self = shift; + + +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'}) { + return 1; +} else { + return undef; +} + +} + + sub StripContent { my %args = @_; my $content = $args{Content}; @@ -887,15 +1014,14 @@ sub StripContent { return '' if not $html and $content =~ /^(--)?\Q$sig\E$/; # Check for html-formatted sig; we don't use EscapeUTF8 here - # because we want to precisely match the escaping that FCKEditor - # uses. see also 311223f5, which fixed this for 4.0 + # because we want to precisely match the escapting that FCKEditor + # uses. $sig =~ s/&/&/g; $sig =~ s/</</g; $sig =~ s/>/>/g; - - return '' - if $html - and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s; + $sig =~ s/"/"/g; + $sig =~ s/'/'/g; + return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s; # Pass it through return $return_content; @@ -963,12 +1089,20 @@ sub MaybeEnableSQLStatementLog { } sub LogRecordedSQLStatements { + my %args = @_; + my $log_sql_statements = RT->Config->Get('StatementLog'); return unless ($log_sql_statements); my @log = $RT::Handle->SQLStatementLog; $RT::Handle->ClearSQLStatementLog; + + $RT::Handle->AddRequestToHistory({ + %{ $args{RequestData} }, + Queries => \@log, + }); + for my $stmt (@log) { my ( $time, $sql, $bind, $duration ) = @{$stmt}; my @bind; @@ -984,17 +1118,296 @@ sub LogRecordedSQLStatements { message => "SQL(" . sprintf( "%.6f", $duration ) . "s): $sql;" - . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" ) + . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" ) ); } } +my $_has_validated_web_config = 0; +sub ValidateWebConfig { + my $self = shift; + + # do this once per server instance, not once per request + return if $_has_validated_web_config; + $_has_validated_web_config = 1; + + if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) { + $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."); + } + + if ($ENV{HTTP_HOST}) { + # match "example.com" or "example.com:80" + my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/; + + if ($host ne RT->Config->Get('WebDomain')) { + $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."); + } + } + else { + if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) { + $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."); + } + } + + #i don't understand how this was ever expected to work + # (even without our dum double // hack)?? + #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) { + ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g; + ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g; + my $script_name_prefix = substr($script_name, 0, length($WebPath)); + if ( $script_name_prefix ne $WebPath ) { + $RT::Logger->warn("The actual SCRIPT_NAME ($script_name) does NOT match the configured WebPath ($WebPath). Perhaps you should Set(\$WebPath, '$script_name_prefix'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); + } +} + +sub ComponentRoots { + my $self = shift; + my %args = ( Names => 0, @_ ); + my @roots; + if (defined $HTML::Mason::Commands::m) { + @roots = $HTML::Mason::Commands::m->interp->comp_root_array; + } else { + @roots = ( + [ local => $RT::MasonLocalComponentRoot ], + (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}), + [ standard => $RT::MasonComponentRoot ] + ); + } + @roots = map { $_->[1] } @roots unless $args{Names}; + return @roots; +} + +our %is_whitelisted_component = ( + # The RSS feed embeds an auth token in the path, but query + # information for the search. Because it's a straight-up read, in + # addition to embedding its own auth, it's fine. + '/NoAuth/rss/dhandler' => 1, +); + +sub IsCompCSRFWhitelisted { + my $comp = shift; + my $ARGS = shift; + + return 1 if $is_whitelisted_component{$comp}; + + my %args = %{ $ARGS }; + + # If the user specifies a *correct* user and pass then they are + # golden. This acts on the presumption that external forms may + # hardcode a username and password -- if a malicious attacker knew + # both already, CSRF is the least of your problems. + my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin'); + if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) { + my $user_obj = RT::CurrentUser->new(); + $user_obj->Load($args{user}); + return 1 if $user_obj->id && $user_obj->IsPassword($args{pass}); + + delete $args{user}; + delete $args{pass}; + } + + # Eliminate arguments that do not indicate an effectful request. + # For example, "id" is acceptable because that is how RT retrieves a + # record. + delete $args{id}; + + # If they have a valid results= from MaybeRedirectForResults, that's + # also fine. + delete $args{results} if $args{results} + and $HTML::Mason::Commands::session{"Actions"}->{$args{results}}; + + # The homepage refresh, which uses the Refresh header, doesn't send + # a referer in most browsers; whitelist the one parameter it reloads + # with, HomeRefreshInterval, which is safe + delete $args{HomeRefreshInterval}; + + # If there are no arguments, then it's likely to be an idempotent + # request, which are not susceptible to CSRF + return 1 if !%args; + + return 0; +} + +sub IsRefererCSRFWhitelisted { + my $referer = _NormalizeHost(shift); + my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL')); + $base_url = $base_url->host_port; + + my $configs; + for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) { + push @$configs,$config; + return 1 if $referer->host_port eq $config; + } + + return (0,$referer,$configs); +} + +=head3 _NormalizeHost + +Takes a URI and creates a URI object that's been normalized +to handle common problems such as localhost vs 127.0.0.1 + +=cut + +sub _NormalizeHost { + my $s = shift; + $s = "http://$s" unless $s =~ /^http/i; + my $uri= URI->new($s); + $uri->host('127.0.0.1') if $uri->host eq 'localhost'; + + return $uri; + +} + +sub IsPossibleCSRF { + my $ARGS = shift; + + # If first request on this session is to a REST endpoint, then + # whitelist the REST endpoints -- and explicitly deny non-REST + # endpoints. We do this because using a REST cookie in a browser + # would open the user to CSRF attacks to the REST endpoints. + my $path = $HTML::Mason::Commands::r->path_info; + $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)} + unless defined $HTML::Mason::Commands::session{'REST'}; + + if ($HTML::Mason::Commands::session{'REST'}) { + return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)}; + my $why = <<EOT; +This login session belongs to a REST client, and cannot be used to +access non-REST interfaces of RT for security reasons. +EOT + my $details = <<EOT; +Please log out and back in to obtain a session for normal browsing. If +you understand the security implications, disabling RT's CSRF protection +will remove this restriction. +EOT + chomp $details; + HTML::Mason::Commands::Abort( $why, Details => $details ); + } + + return 0 if IsCompCSRFWhitelisted( + $HTML::Mason::Commands::m->request_comp->path, + $ARGS + ); + + # if there is no Referer header then assume the worst + return (1, + "your browser did not supply a Referrer header", # loc + ) if !$ENV{HTTP_REFERER}; + + my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER}); + return 0 if $whitelisted; + + if ( @$configs > 1 ) { + return (1, + "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc + $browser->host_port, + shift @$configs, + join(', ', @$configs) ); + } + + return (1, + "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc + $browser->host_port, + $configs->[0]); +} + +sub ExpandCSRFToken { + my $ARGS = shift; + + my $token = delete $ARGS->{CSRF_Token}; + return unless $token; + + my $data = $HTML::Mason::Commands::session{'CSRF'}{$token}; + return unless $data; + return unless $data->{path} eq $HTML::Mason::Commands::r->path_info; + + my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; + return unless $user->ValidateAuthString( $data->{auth}, $token ); + + %{$ARGS} = %{$data->{args}}; + $HTML::Mason::Commands::DECODED_ARGS = $ARGS; + + # We explicitly stored file attachments with the request, but not in + # the session yet, as that would itself be an attack. Put them into + # the session now, so they'll be visible. + if ($data->{attach}) { + my $filename = $data->{attach}{filename}; + my $mime = $data->{attach}{mime}; + $HTML::Mason::Commands::session{'Attachments'}{$filename} + = $mime; + } + + return 1; +} + +sub StoreRequestToken { + my $ARGS = shift; + + my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024)); + my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; + my $data = { + auth => $user->GenerateAuthString( $token ), + path => $HTML::Mason::Commands::r->path_info, + args => $ARGS, + }; + if ($ARGS->{Attach}) { + my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' ); + my $file_path = delete $ARGS->{'Attach'}; + $data->{attach} = { + filename => Encode::decode_utf8("$file_path"), + mime => $attachment, + }; + } + + $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data; + $HTML::Mason::Commands::session{'i'}++; + return $token; +} + +sub MaybeShowInterstitialCSRFPage { + my $ARGS = shift; + + return unless RT->Config->Get('RestrictReferrer'); + + # Deal with the form token provided by the interstitial, which lets + # browsers which never set referer headers still use RT, if + # painfully. This blows values into ARGS + return if ExpandCSRFToken($ARGS); + + my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); + return if !$is_csrf; + + $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc)); + + my $token = StoreRequestToken($ARGS); + $HTML::Mason::Commands::m->comp( + '/Elements/CSRF', + OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info, + Reason => HTML::Mason::Commands::loc( $msg, @loc ), + Token => $token, + ); + # Calls abort, never gets here +} + package HTML::Mason::Commands; use vars qw/$r $m %session/; -# {{{ loc +sub Menu { + return $HTML::Mason::Commands::m->notes('menu'); +} + +sub PageMenu { + return $HTML::Mason::Commands::m->notes('page-menu'); +} + +sub PageWidgets { + return $HTML::Mason::Commands::m->notes('page-widgets'); +} + + =head2 loc ARRAY @@ -1025,9 +1438,7 @@ sub loc { } } -# }}} -# {{{ loc_fuzzy =head2 loc_fuzzy STRING @@ -1047,14 +1458,12 @@ sub loc_fuzzy { { return ( $session{'CurrentUser'}->loc_fuzzy($msg) ); } else { - my $u = RT::CurrentUser->new( $RT::SystemUser->Id ); + my $u = RT::CurrentUser->new( RT->SystemUser->Id ); return ( $u->loc_fuzzy($msg) ); } } -# }}} -# {{{ sub Abort # Error - calls Error and aborts sub Abort { my $why = shift; @@ -1072,9 +1481,79 @@ sub Abort { } } -# }}} +sub MaybeRedirectForResults { + my %args = ( + Path => $HTML::Mason::Commands::m->request_comp->path, + Arguments => {}, + Anchor => undef, + Actions => undef, + Force => 0, + @_ + ); + my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } ); + return unless $has_actions || $args{'Force'}; + + my %arguments = %{ $args{'Arguments'} }; + + if ( $has_actions ) { + my $key = Digest::MD5::md5_hex( rand(1024) ); + push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} }; + $session{'i'}++; + $arguments{'results'} = $key; + } + + $args{'Path'} =~ s!^/+!!; + my $url = RT->Config->Get('WebURL') . $args{Path}; + + if ( keys %arguments ) { + $url .= '?'. $m->comp( '/Elements/QueryString', %arguments ); + } + if ( $args{'Anchor'} ) { + $url .= "#". $args{'Anchor'}; + } + return RT::Interface::Web::Redirect($url); +} -# {{{ sub CreateTicket +=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF + +If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket, +redirect to the approvals display page, preserving any arguments. + +C<Path>s matching C<Whitelist> are let through. + +This is a no-op if the C<ForceApprovalsView> option isn't enabled. + +=cut + +sub MaybeRedirectToApproval { + my %args = ( + Path => $HTML::Mason::Commands::m->request_comp->path, + ARGSRef => {}, + Whitelist => undef, + @_ + ); + + return unless $ENV{REQUEST_METHOD} eq 'GET'; + + my $id = $args{ARGSRef}->{id}; + + if ( $id + and RT->Config->Get('ForceApprovalsView') + and not $args{Path} =~ /$args{Whitelist}/) + { + my $ticket = RT::Ticket->new( $session{'CurrentUser'} ); + $ticket->Load($id); + + if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') { + MaybeRedirectForResults( + Path => "/Approvals/Display.html", + Force => 1, + Anchor => $args{ARGSRef}->{Anchor}, + Arguments => $args{ARGSRef}, + ); + } + } +} =head2 CreateTicket ARGS @@ -1087,9 +1566,9 @@ sub CreateTicket { my (@Actions); - my $Ticket = new RT::Ticket( $session{'CurrentUser'} ); + my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); - my $Queue = new RT::Queue( $session{'CurrentUser'} ); + my $Queue = RT::Queue->new( $session{'CurrentUser'} ); unless ( $Queue->Load( $ARGS{'Queue'} ) ) { Abort('Queue not found'); } @@ -1100,12 +1579,12 @@ sub CreateTicket { my $due; if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) { - $due = new RT::Date( $session{'CurrentUser'} ); + $due = RT::Date->new( $session{'CurrentUser'} ); $due->Set( Format => 'unknown', Value => $ARGS{'Due'} ); } my $starts; if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) { - $starts = new RT::Date( $session{'CurrentUser'} ); + $starts = RT::Date->new( $session{'CurrentUser'} ); $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} ); } @@ -1139,9 +1618,8 @@ sub CreateTicket { } foreach my $argument (qw(Encrypt Sign)) { - $MIMEObj->head->add( - "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} ) - ) if defined $ARGS{$argument}; + $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 ) + if defined $ARGS{$argument}; } my %create_args = ( @@ -1165,17 +1643,13 @@ sub CreateTicket { MIMEObj => $MIMEObj ); - my @temp_squelch; + my @txn_squelch; foreach my $type (qw(Requestor Cc AdminCc)) { - push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) + push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] }; - - } - - if (@temp_squelch) { - require RT::Action::SendEmail; - RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch ); } + $create_args{TransSquelchMailTo} = \@txn_squelch + if @txn_squelch; if ( $ARGS{'AttachTickets'} ) { require RT::Action::SendEmail; @@ -1197,6 +1671,7 @@ sub CreateTicket { my $cfid = $1; my $cf = RT::CustomField->new( $session{'CurrentUser'} ); + $cf->SetContextObject( $Queue ); $cf->Load($cfid); unless ( $cf->id ) { $RT::Logger->error( "Couldn't load custom field #" . $cfid ); @@ -1259,9 +1734,7 @@ sub CreateTicket { } -# }}} -# {{{ sub LoadTicket - loads a ticket =head2 LoadTicket id @@ -1291,9 +1764,7 @@ sub LoadTicket { return $Ticket; } -# }}} -# {{{ sub ProcessUpdateMessage =head2 ProcessUpdateMessage @@ -1341,7 +1812,7 @@ sub ProcessUpdateMessage { return; } - if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) { + if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) { $args{ARGSRef}->{'UpdateSubject'} = undef; } @@ -1351,7 +1822,7 @@ sub ProcessUpdateMessage { Type => $args{ARGSRef}->{'UpdateContentType'}, ); - $Message->head->add( 'Message-ID' => Encode::encode_utf8( + $Message->head->replace( 'Message-ID' => Encode::encode_utf8( RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} ) ) ); my $old_txn = RT::Transaction->new( $session{'CurrentUser'} ); @@ -1381,9 +1852,6 @@ sub ProcessUpdateMessage { : ( $args{ARGSRef}->{'AttachTickets'} ) ); } - my $bcc = $args{ARGSRef}->{'UpdateBcc'}; - my $cc = $args{ARGSRef}->{'UpdateCc'}; - my %txn_customfields; foreach my $key ( keys %{ $args{ARGSRef} } ) { @@ -1393,70 +1861,83 @@ sub ProcessUpdateMessage { } my %message_args = ( - CcMessageTo => $cc, - BccMessageTo => $bcc, - Sign => $args{ARGSRef}->{'Sign'}, - Encrypt => $args{ARGSRef}->{'Encrypt'}, + Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ), + Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ), MIMEObj => $Message, TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}, CustomFields => \%txn_customfields, ); - my @temp_squelch; + _ProcessUpdateMessageRecipients( + MessageArgs => \%message_args, + %args, + ); + + my @results; + if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) { + my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args); + push( @results, $Description ); + $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) { + my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args); + push( @results, $Description ); + $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + } else { + push( @results, + loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") ); + } + return @results; +} + +sub _ProcessUpdateMessageRecipients { + my %args = ( + ARGSRef => undef, + TicketObj => undef, + MessageArgs => undef, + @_, + ); + + my $bcc = $args{ARGSRef}->{'UpdateBcc'}; + my $cc = $args{ARGSRef}->{'UpdateCc'}; + + my $message_args = $args{MessageArgs}; + + $message_args->{CcMessageTo} = $cc; + $message_args->{BccMessageTo} = $bcc; + + my @txn_squelch; foreach my $type (qw(Cc AdminCc)) { if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { - push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} ); - push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses; - push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses; + push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} ); + push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses; + push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses; } } if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { - push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} ); - push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses; - } + push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} ); + push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses; - if (@temp_squelch) { - require RT::Action::SendEmail; - RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch ); } + push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo}; + $message_args->{SquelchMailTo} = \@txn_squelch + if @txn_squelch; + unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) { foreach my $key ( keys %{ $args{ARGSRef} } ) { next unless $key =~ /^Update(Cc|Bcc)-(.*)$/; my $var = ucfirst($1) . 'MessageTo'; my $value = $2; - if ( $message_args{$var} ) { - $message_args{$var} .= ", $value"; + if ( $message_args->{$var} ) { + $message_args->{$var} .= ", $value"; } else { - $message_args{$var} = $value; + $message_args->{$var} = $value; } } } - - my @results; - # Do the update via the appropriate Ticket method - if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) { - my ( $Transaction, $Description, $Object ) = - $args{TicketObj}->Comment(%message_args); - push( @results, $Description ); - #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; - } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) { - my ( $Transaction, $Description, $Object ) = - $args{TicketObj}->Correspond(%message_args); - push( @results, $Description ); - #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; - } else { - push( @results, - loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") ); - } - return @results; } -# }}} - -# {{{ sub MakeMIMEEntity - =head2 MakeMIMEEntity PARAMHASH Takes a paramhash Subject, Body and AttachmentFieldName. @@ -1481,6 +1962,7 @@ sub MakeMIMEEntity { ); my $Message = MIME::Entity->build( Type => 'multipart/mixed', + "Message-Id" => RT::Interface::Email::GenMessageId, map { $_ => Encode::encode_utf8( $args{ $_} ) } grep defined $args{$_}, qw(Subject From Cc) ); @@ -1500,8 +1982,8 @@ sub MakeMIMEEntity { if ( $args{'AttachmentFieldName'} ) { my $cgi_object = $m->cgi_object; - - if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) { + my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ); + if ( defined $filehandle && length $filehandle ) { my ( @content, $buffer ); while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) { @@ -1510,10 +1992,7 @@ sub MakeMIMEEntity { my $uploadinfo = $cgi_object->uploadInfo($filehandle); - # Prefer the cached name first over CGI.pm stringification. - my $filename = $RT::Mason::CGI::Filename; - $filename = "$filehandle" unless defined $filename; - $filename = Encode::encode_utf8( $filename ); + my $filename = "$filehandle"; $filename =~ s{^.*[\\/]}{}; $Message->attach( @@ -1524,6 +2003,9 @@ sub MakeMIMEEntity { if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) { $Message->head->set( 'Subject' => $filename ); } + + # Attachment parts really shouldn't get a Message-ID + $Message->head->delete('Message-ID'); } } @@ -1535,9 +2017,7 @@ sub MakeMIMEEntity { } -# }}} -# {{{ sub ParseDateToISO =head2 ParseDateToISO @@ -1557,9 +2037,7 @@ sub ParseDateToISO { return ( $date_obj->ISO ); } -# }}} -# {{{ sub ProcessACLChanges sub ProcessACLChanges { my $ARGSref = shift; @@ -1608,9 +2086,145 @@ sub ProcessACLChanges { return (@results); } -# }}} -# {{{ sub UpdateRecordObj +=head2 ProcessACLs + +ProcessACLs expects values from a series of checkboxes that describe the full +set of rights a principal should have on an object. + +It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId +instead of with the prefixes Grant/RevokeRight. Each input should be an array +listing the rights the principal should have, and ProcessACLs will modify the +current rights to match. Additionally, the previously unused CheckACL input +listing PrincipalId-ObjType-ObjId is now used to catch cases when all the +rights are removed from a principal and as such no SetRights input is +submitted. + +=cut + +sub ProcessACLs { + my $ARGSref = shift; + my (%state, @results); + + my $CheckACL = $ARGSref->{'CheckACL'}; + my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL); + + # Check if we want to grant rights to a previously rights-less user + for my $type (qw(user group)) { + my $key = "AddPrincipalForRights-$type"; + + next unless $ARGSref->{$key}; + + my $principal; + if ( $type eq 'user' ) { + $principal = RT::User->new( $session{'CurrentUser'} ); + $principal->LoadByCol( Name => $ARGSref->{$key} ); + } + else { + $principal = RT::Group->new( $session{'CurrentUser'} ); + $principal->LoadUserDefinedGroup( $ARGSref->{$key} ); + } + + unless ($principal->PrincipalId) { + push @results, loc("Couldn't load the specified principal"); + next; + } + + my $principal_id = $principal->PrincipalId; + + # Turn our addprincipal rights spec into a real one + for my $arg (keys %$ARGSref) { + next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/; + + my $tuple = "$principal_id-$1"; + my $key = "SetRights-$tuple"; + + # If we have it already, that's odd, but merge them + if (grep { $_ eq $tuple } @check) { + $ARGSref->{$key} = [ + (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}), + (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}), + ]; + } else { + $ARGSref->{$key} = $ARGSref->{$arg}; + push @check, $tuple; + } + } + } + + # Build our rights state for each Principal-Object tuple + foreach my $arg ( keys %$ARGSref ) { + next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/; + + my $tuple = $1; + my $value = $ARGSref->{$arg}; + my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value); + next unless @rights; + + $state{$tuple} = { map { $_ => 1 } @rights }; + } + + foreach my $tuple (List::MoreUtils::uniq @check) { + next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/; + + my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 ); + + my $principal = RT::Principal->new( $session{'CurrentUser'} ); + $principal->Load($principal_id); + + my $obj; + if ( $object_type eq 'RT::System' ) { + $obj = $RT::System; + } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { + $obj = $object_type->new( $session{'CurrentUser'} ); + $obj->Load($object_id); + unless ( $obj->id ) { + $RT::Logger->error("couldn't load $object_type #$object_id"); + next; + } + } else { + $RT::Logger->error("object type '$object_type' is incorrect"); + push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) ); + next; + } + + my $acls = RT::ACL->new($session{'CurrentUser'}); + $acls->LimitToObject( $obj ); + $acls->LimitToPrincipal( Id => $principal_id ); + + while ( my $ace = $acls->Next ) { + my $right = $ace->RightName; + + # Has right and should have right + next if delete $state{$tuple}->{$right}; + + # Has right and shouldn't have right + my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right ); + push @results, $msg; + } + + # For everything left, they don't have the right but they should + for my $right (keys %{ $state{$tuple} || {} }) { + delete $state{$tuple}->{$right}; + my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right ); + push @results, $msg; + } + + # Check our state for leftovers + if ( keys %{ $state{$tuple} || {} } ) { + my $missed = join '|', %{$state{$tuple} || {}}; + $RT::Logger->warn( + "Uh-oh, it looks like we somehow missed a right in " + ."ProcessACLs. Here's what was leftover: $missed" + ); + } + } + + return (@results); +} + + + =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs) @@ -1639,9 +2253,7 @@ sub UpdateRecordObject { return (@results); } -# }}} -# {{{ Sub ProcessCustomFieldUpdates sub ProcessCustomFieldUpdates { my %args = ( @@ -1694,9 +2306,7 @@ sub ProcessCustomFieldUpdates { return (@results); } -# }}} -# {{{ sub ProcessTicketBasics =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS ); @@ -1715,7 +2325,9 @@ sub ProcessTicketBasics { my $TicketObj = $args{'TicketObj'}; my $ARGSRef = $args{'ARGSRef'}; - # {{{ Set basic fields + my $OrigOwner = $TicketObj->Owner; + + # Set basic fields my @attribs = qw( Subject FinalPriority @@ -1728,11 +2340,15 @@ sub ProcessTicketBasics { Queue ); - if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) { - my $tempqueue = RT::Queue->new($RT::SystemUser); - $tempqueue->Load( $ARGSRef->{'Queue'} ); - if ( $tempqueue->id ) { - $ARGSRef->{'Queue'} = $tempqueue->id; + # Canonicalize Queue and Owner to their IDs if they aren't numeric + for my $field (qw(Queue Owner)) { + if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) { + my $class = $field eq 'Owner' ? "RT::User" : "RT::$field"; + my $temp = $class->new(RT->SystemUser); + $temp->Load( $ARGSRef->{$field} ); + if ( $temp->id ) { + $ARGSRef->{$field} = $temp->id; + } } } @@ -1747,12 +2363,15 @@ sub ProcessTicketBasics { ); # We special case owner changing, so we can use ForceOwnerChange - if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) { + if ( $ARGSRef->{'Owner'} + && $ARGSRef->{'Owner'} !~ /\D/ + && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) { my ($ChownType); if ( $ARGSRef->{'ForceOwnerChange'} ) { $ChownType = "Force"; - } else { - $ChownType = "Give"; + } + else { + $ChownType = "Set"; } my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType ); @@ -1764,7 +2383,65 @@ sub ProcessTicketBasics { return (@results); } -# }}} +sub ProcessTicketReminders { + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + + my $Ticket = $args{'TicketObj'}; + my $args = $args{'ARGSRef'}; + my @results; + + my $reminder_collection = $Ticket->Reminders->Collection; + + if ( $args->{'update-reminders'} ) { + while ( my $reminder = $reminder_collection->Next ) { + my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve; + if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) { + $Ticket->Reminders->Resolve($reminder); + } + elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) { + $Ticket->Reminders->Open($reminder); + } + + if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) { + $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ; + } + + if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) { + $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ; + } + + if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) { + my $DateObj = RT::Date->new( $session{'CurrentUser'} ); + $DateObj->Set( + Format => 'unknown', + Value => $args->{ 'Reminder-Due-' . $reminder->id } + ); + if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) { + $reminder->SetDue( $DateObj->ISO ); + } + } + } + } + + if ( $args->{'NewReminder-Subject'} ) { + my $due_obj = RT::Date->new( $session{'CurrentUser'} ); + $due_obj->Set( + Format => 'unknown', + Value => $args->{'NewReminder-Due'} + ); + my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add( + Subject => $args->{'NewReminder-Subject'}, + Owner => $args->{'NewReminder-Owner'}, + Due => $due_obj->ISO + ); + push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'}); + } + return @results; +} sub ProcessTicketCustomFieldUpdates { my %args = @_; @@ -1817,6 +2494,7 @@ sub ProcessObjectCustomFieldUpdates { foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) { my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} ); + $CustomFieldObj->SetContextObject($Object); $CustomFieldObj->LoadById($cf); unless ( $CustomFieldObj->id ) { $RT::Logger->warning("Couldn't load custom field #$cf"); @@ -1838,7 +2516,7 @@ sub ProcessObjectCustomFieldUpdates { sub _ProcessObjectCustomFieldUpdates { my %args = @_; my $cf = $args{'CustomField'}; - my $cf_type = $cf->Type; + my $cf_type = $cf->Type || ''; # Remove blank Values since the magic field will take care of this. Sometimes # the browser gives you a blank value which causes CFs to be processed twice @@ -1939,6 +2617,9 @@ sub _ProcessObjectCustomFieldUpdates { # For Date Cfs, @values is empty when there is no changes (no datas in form input) return @results if ( $cf->Type eq 'Date' && ! @values ); + # For Date Cfs, @values is empty when there is no changes (no datas in form input) + return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values ); + $cf_values->RedoSearch; while ( my $cf_value = $cf_values->Next ) { next if $values_hash{ $cf_value->id }; @@ -1985,7 +2666,6 @@ sub _ProcessObjectCustomFieldUpdates { return @results; } -# {{{ sub ProcessTicketWatchers =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS ); @@ -2067,9 +2747,7 @@ sub ProcessTicketWatchers { return (@results); } -# }}} -# {{{ sub ProcessTicketDates =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS ); @@ -2089,7 +2767,7 @@ sub ProcessTicketDates { my (@results); - # {{{ Set date fields + # Set date fields my @date_fields = qw( Told Resolved @@ -2125,9 +2803,7 @@ sub ProcessTicketDates { return (@results); } -# }}} -# {{{ sub ProcessTicketLinks =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS ); @@ -2157,7 +2833,6 @@ sub ProcessTicketLinks { return (@results); } -# }}} sub ProcessRecordLinks { my %args = ( @@ -2291,6 +2966,99 @@ sub ProcessColumnMapValue { return $value; } +=head2 GetPrincipalsMap OBJECT, CATEGORIES + +Returns an array suitable for passing to /Admin/Elements/EditRights with the +principal collections mapped from the categories given. + +=cut + +sub GetPrincipalsMap { + my $object = shift; + my @map; + for (@_) { + if (/System/) { + my $system = RT::Groups->new($session{'CurrentUser'}); + $system->LimitToSystemInternalGroups(); + $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); + push @map, [ + 'System' => $system, # loc_left_pair + 'Type' => 1, + ]; + } + elsif (/Groups/) { + my $groups = RT::Groups->new($session{'CurrentUser'}); + $groups->LimitToUserDefinedGroups(); + $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); + + # Only show groups who have rights granted on this object + $groups->WithGroupRight( + Right => '', + Object => $object, + IncludeSystemRights => 0, + IncludeSubgroupMembers => 0, + ); + + push @map, [ + 'User Groups' => $groups, # loc_left_pair + 'Name' => 0 + ]; + } + elsif (/Roles/) { + my $roles = RT::Groups->new($session{'CurrentUser'}); + + if ($object->isa('RT::System')) { + $roles->LimitToRolesForSystem(); + } + elsif ($object->isa('RT::Queue')) { + $roles->LimitToRolesForQueue($object->Id); + } + else { + $RT::Logger->warn("Skipping unknown object type ($object) for Role principals"); + next; + } + $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); + push @map, [ + 'Roles' => $roles, # loc_left_pair + 'Type' => 1 + ]; + } + elsif (/Users/) { + my $Users = RT->PrivilegedUsers->UserMembersObj(); + $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); + + # Only show users who have rights granted on this object + my $group_members = $Users->WhoHaveGroupRight( + Right => '', + Object => $object, + IncludeSystemRights => 0, + IncludeSubgroupMembers => 0, + ); + + # Limit to UserEquiv groups + my $groups = $Users->NewAlias('Groups'); + $Users->Join( + ALIAS1 => $groups, + FIELD1 => 'id', + ALIAS2 => $group_members, + FIELD2 => 'GroupId' + ); + $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' ); + $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' ); + + + my $display = sub { + $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1) + }; + push @map, [ + 'Users' => $Users, # loc_left_pair + $display => 0 + ]; + } + } + return @map; +} + =head2 _load_container_object ( $type, $id ); Instantiate container object for saving searches. @@ -2322,6 +3090,103 @@ sub _parse_saved_search { return ( _load_container_object( $obj_type, $obj_id ), $search_id ); } +=head2 ScrubHTML content + +Removes unsafe and undesired HTML from the passed content + +=cut + +my $SCRUBBER; +sub ScrubHTML { + my $Content = shift; + $SCRUBBER = _NewScrubber() unless $SCRUBBER; + + $Content = '' if !defined($Content); + return $SCRUBBER->scrub($Content); +} + +=head2 _NewScrubber + +Returns a new L<HTML::Scrubber> object. + +If you need to be more lax about what HTML tags and attributes are allowed, +create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the +following: + + package HTML::Mason::Commands; + # Let tables through + push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH); + 1; + +=cut + +our @SCRUBBER_ALLOWED_TAGS = 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 BDO +); + +our %SCRUBBER_ALLOWED_ATTRIBUTES = ( + # Match http, ftp and relative urls + # XXX: we also scrub format strings with this module then allow simple config options + href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i, + face => 1, + size => 1, + target => 1, + style => qr{ + ^(?:\s* + (?:(?:background-)?color: \s* + (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d) + \#[a-f0-9]{3,6} | # #fff or #ffffff + [\w\-]+ # green, light-blue, etc. + ) | + text-align: \s* \w+ | + font-size: \s* [\w.\-]+ | + font-family: \s* [\w\s"',.\-]+ | + font-weight: \s* [\w\-]+ | + + # MS Office styles, which are probably fine. If we don't, then any + # associated styles in the same attribute get stripped. + mso-[\w\-]+?: \s* [\w\s"',.\-]+ + )\s* ;? \s*) + +$ # one or more of these allowed properties from here 'till sunset + }ix, + dir => qr/^(rtl|ltr)$/i, + lang => qr/^\w+(-\w+)?$/, +); + +our %SCRUBBER_RULES = (); + +sub _NewScrubber { + require HTML::Scrubber; + my $scrubber = HTML::Scrubber->new(); + $scrubber->default( + 0, + { + %SCRUBBER_ALLOWED_ATTRIBUTES, + '*' => 0, # require attributes be explicitly allowed + }, + ); + $scrubber->deny(qw[*]); + $scrubber->allow(@SCRUBBER_ALLOWED_TAGS); + $scrubber->rules(%SCRUBBER_RULES); + + # Scrubbing comments is vital since IE conditional comments can contain + # arbitrary HTML and we'd pass it right on through. + $scrubber->comment(0); + + return $scrubber; +} + +=head2 JSON + +Redispatches to L<RT::Interface::Web/EncodeJSON> + +=cut + +sub JSON { + RT::Interface::Web::EncodeJSON(@_); +} + package RT::Interface::Web; RT::Base->_ImportOverlays(); diff --git a/rt/lib/RT/Interface/Web/Handler.pm b/rt/lib/RT/Interface/Web/Handler.pm index 4bb648451..a740167c6 100644 --- a/rt/lib/RT/Interface/Web/Handler.pm +++ b/rt/lib/RT/Interface/Web/Handler.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -47,6 +47,8 @@ # END BPS TAGGED BLOCK }}} package RT::Interface::Web::Handler; +use warnings; +use strict; use CGI qw/-private_tempfiles/; use MIME::Entity; @@ -54,53 +56,29 @@ use Text::Wrapper; use CGI::Cookie; use Time::ParseDate; use Time::HiRes; -use HTML::Entities; use HTML::Scrubber; -use RT::Interface::Web::Handler; +use RT::Interface::Web; use RT::Interface::Web::Request; use File::Path qw( rmtree ); use File::Glob qw( bsd_glob ); use File::Spec::Unix; sub DefaultHandlerArgs { ( - comp_root => [ - [ local => $RT::MasonLocalComponentRoot ], - (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}), - [ standard => $RT::MasonComponentRoot ] + comp_root => [ + RT::Interface::Web->ComponentRoots( Names => 1 ), ], default_escape_flags => 'h', data_dir => "$RT::MasonDataDir", - allow_globals => [qw(%session)], + allow_globals => [qw(%session $DECODED_ARGS)], # Turn off static source if we're in developer mode. static_source => (RT->Config->Get('DevelMode') ? '0' : '1'), use_object_files => (RT->Config->Get('DevelMode') ? '0' : '1'), autoflush => 0, - error_format => (RT->Config->Get('DevelMode') ? 'html': 'brief'), + error_format => (RT->Config->Get('DevelMode') ? 'html': 'rt_error'), request_class => 'RT::Interface::Web::Request', named_component_subs => $INC{'Devel/Cover.pm'} ? 1 : 0, ) }; -# {{{ sub new - -=head2 new - - Constructs a web handler of the appropriate class. - Takes options to pass to the constructor. - -=cut - -sub new { - my $class = shift; - $class->InitSessionDir; - - if ( ($mod_perl::VERSION && $mod_perl::VERSION >= 1.9908) || $CGI::MOD_PERL) { - goto &NewApacheHandler; - } - else { - goto &NewCGIHandler; - } -} - sub InitSessionDir { # Activate the following if running httpd as root (the normal case). # Resets ownership of all files created by Mason at startup. @@ -125,89 +103,40 @@ sub InitSessionDir { } -# }}} - -# {{{ sub NewApacheHandler - -=head2 NewApacheHandler - - Takes extra options to pass to HTML::Mason::ApacheHandler->new - Returns a new Mason::ApacheHandler object - -=cut - -sub NewApacheHandler { - require HTML::Mason::ApacheHandler; - return NewHandler('HTML::Mason::ApacheHandler', args_method => "CGI", @_); -} - -# }}} - -# {{{ sub NewCGIHandler - -=head2 NewCGIHandler - - Returns a new Mason::CGIHandler object - -=cut - -sub NewCGIHandler { - require HTML::Mason::CGIHandler; - return NewHandler( - 'HTML::Mason::CGIHandler', - out_method => sub { - my $m = HTML::Mason::Request->instance; - my $r = $m->cgi_request; - - # Send headers if they have not been sent by us or by user. - $r->send_http_header unless $r->http_header_sent; - - # Set up a default - $r->content_type('text/html; charset=utf-8') - unless $r->content_type; - - if ( $r->content_type =~ /charset=([\w-]+)$/ ) { - my $enc = $1; - if ( lc $enc !~ /utf-?8$/ ) { - for my $str (@_) { - next unless $str; - - # only encode perl internal strings - next unless utf8::is_utf8($str); - $str = Encode::encode( $enc, $str ); - } - } - } - - # default to utf8 encoding - for my $str (@_) { - next unless $str; - next unless utf8::is_utf8($str); - $str = Encode::encode( 'utf8', $str ); - } - - # We could perhaps install a new, faster out_method here that - # wouldn't have to keep checking whether headers have been - # sent and what the $r->method is. That would require - # additions to the Request interface, though. - print STDOUT grep {defined} @_; - }, - @_ - ); -} +use UNIVERSAL::require; sub NewHandler { my $class = shift; + $class->require or die $!; my $handler = $class->new( DefaultHandlerArgs(), + RT->Config->Get('MasonParameters'), @_ ); $handler->interp->set_escape( h => \&RT::Interface::Web::EscapeUTF8 ); $handler->interp->set_escape( u => \&RT::Interface::Web::EscapeURI ); + $handler->interp->set_escape( j => \&RT::Interface::Web::EscapeJS ); return($handler); } +=head2 _mason_dir_index + +=cut + +sub _mason_dir_index { + my ($self, $interp, $path) = @_; + $path =~ s!/$!!; + if ( !$interp->comp_exists( $path ) + && $interp->comp_exists( $path . "/index.html" ) ) + { + return $path . "/index.html"; + } + + return $path; +} + + =head2 CleanupRequest Clean ups globals, caches and other things that could be still @@ -266,9 +195,104 @@ sub CleanupRequest { delete $RT::System->{attributes}; # Explicitly remove any tmpfiles that GPG opened, and close their - # filehandles. - File::Temp::cleanup; + # filehandles. unless we are doing inline psgi testing, which kills all the tmp file created by tests. + File::Temp::cleanup() + unless $INC{'Test/WWW/Mechanize/PSGI.pm'}; + + +} + + +sub HTML::Mason::Exception::as_rt_error { + my ($self) = @_; + $RT::Logger->error( $self->full_message ); + return "An internal RT error has occurred. Your administrator can find more details in RT's log files."; +} + + +# PSGI App + +use RT::Interface::Web::Handler; +use CGI::Emulate::PSGI; +use Plack::Request; +use Plack::Response; +use Plack::Util; +use Encode qw(encode_utf8); + +sub PSGIApp { + my $self = shift; + + # XXX: this is fucked + require HTML::Mason::CGIHandler; + require HTML::Mason::PSGIHandler::Streamy; + my $h = RT::Interface::Web::Handler::NewHandler('HTML::Mason::PSGIHandler::Streamy'); + + $self->InitSessionDir; + + return sub { + my $env = shift; + RT::ConnectToDatabase() unless RT->InstallMode; + + my $req = Plack::Request->new($env); + + # CGI.pm normalizes .. out of paths so when you requested + # /NoAuth/../Ticket/Display.html we saw Ticket/Display.html + # PSGI doesn't normalize .. so we have to deal ourselves. + if ( $req->path_info =~ m{/\.} ) { + $RT::Logger->crit("Invalid request for ".$req->path_info." aborting"); + my $res = Plack::Response->new(400); + return $self->_psgi_response_cb($res->finalize,sub { $self->CleanupRequest }); + } + $env->{PATH_INFO} = $self->_mason_dir_index( $h->interp, $req->path_info); + + my $ret; + { + # XXX: until we get rid of all $ENV stuff. + local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env)); + + $ret = $h->handle_psgi($env); + } + + $RT::Logger->crit($@) if $@ && $RT::Logger; + warn $@ if $@ && !$RT::Logger; + if (ref($ret) eq 'CODE') { + my $orig_ret = $ret; + $ret = sub { + my $respond = shift; + local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env)); + $orig_ret->($respond); + }; + } + + return $self->_psgi_response_cb($ret, + sub { + $self->CleanupRequest() + }); +}; + +sub _psgi_response_cb { + my $self = shift; + my ($ret, $cleanup) = @_; + Plack::Util::response_cb + ($ret, + sub { + my $res = shift; + + if ( RT->Config->Get('Framebusting') ) { + # XXX TODO: Do we want to make the value of this header configurable? + Plack::Util::header_set($res->[1], 'X-Frame-Options' => 'DENY'); + } + + return sub { + if (!defined $_[0]) { + $cleanup->(); + return ''; + } + return utf8::is_utf8($_[0]) ? encode_utf8($_[0]) : $_[0]; + return $_[0]; + }; + }); + } } -# }}} 1; diff --git a/rt/lib/RT/Interface/Web/Menu.pm b/rt/lib/RT/Interface/Web/Menu.pm index 3b6ce888e..6b351e94b 100644 --- a/rt/lib/RT/Interface/Web/Menu.pm +++ b/rt/lib/RT/Interface/Web/Menu.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -48,22 +48,267 @@ package RT::Interface::Web::Menu; +use strict; +use warnings; + + +use base qw/Class::Accessor::Fast/; +use URI; +use Scalar::Util qw(weaken); + +__PACKAGE__->mk_accessors(qw( + key title description raw_html escape_title sort_order target class +)); + +=head1 NAME + +RT::Interface::Web::Menu - Handle the API for menu navigation + +=head1 METHODS + +=head2 new PARAMHASH + +Creates a new L<RT::Interface::Web::Menu> object. Possible keys in the +I<PARAMHASH> are L</parent>, L</title>, L</description>, L</path>, +L</raw_html>, L<escape_title>, L</sort_order>, L</class>, L</target> and +L</active>. See the subroutines with the respective name below for +each option's use. + +=cut sub new { - my $class = shift; - my $self = bless {}, $class; - $self->{'root_node'} = RT::Interface::Web::Menu::Item->new(); + my $package = shift; + my $args = ref($_[0]) eq 'HASH' ? shift @_ : {@_}; + + my $parent = delete $args->{'parent'}; + $args->{sort_order} ||= 0; + + # Class::Accessor only wants a hashref; + my $self = $package->SUPER::new( $args ); + + # make sure our reference is weak + $self->parent($parent) if defined $parent; + return $self; } -sub as_hash_of_hashes { +=head2 title [STRING] + +Sets or returns the string that the menu item will be displayed as. + +=head2 escape_title [BOOLEAN] + +Sets or returns whether or not to HTML escape the title before output. + +=head2 parent [MENU] +Gets or sets the parent L<RT::Interface::Web::Menu> of this item; this defaults +to null. This ensures that the reference is weakened. + +=head2 raw_html [STRING] + +Sets the content of this menu item to a raw blob of HTML. When building the +menu, rather than constructing a link, we will return this raw content. No +escaping is done. + +=cut + +sub parent { + my $self = shift; + if (@_) { + $self->{parent} = shift; + weaken $self->{parent}; + } + + return $self->{parent}; +} + + +=head2 sort_order [NUMBER] + +Gets or sets the sort order of the item, as it will be displayed under +the parent. This defaults to adding onto the end. + +=head2 target [STRING] + +Get or set the frame or pseudo-target for this link. something like L<_blank> + +=head2 class [STRING] + +Gets or sets the CSS class the menu item should have in addition to the default +classes. This is only used if L</raw_html> isn't specified. + +=head2 path + +Gets or sets the URL that the menu's link goes to. If the link +provided is not absolute (does not start with a "/"), then is is +treated as relative to it's parent's path, and made absolute. + +=cut + +sub path { + my $self = shift; + if (@_) { + $self->{path} = shift; + $self->{path} = URI->new_abs($self->{path}, $self->parent->path . "/")->as_string + if defined $self->{path} and $self->parent and $self->parent->path; + $self->{path} =~ s!///!/! if $self->{path}; + } + return $self->{path}; +} + +=head2 active [BOOLEAN] + +Gets or sets if the menu item is marked as active. Setting this +cascades to all of the parents of the menu item. + +This is currently B<unused>. + +=cut + +sub active { + my $self = shift; + if (@_) { + $self->{active} = shift; + $self->parent->active($self->{active}) if defined $self->parent; + } + return $self->{active}; } -sub root { +=head2 child KEY [, PARAMHASH] + +If only a I<KEY> is provided, returns the child with that I<KEY>. + +Otherwise, creates or overwrites the child with that key, passing the +I<PARAMHASH> to L<RT::Interface::Web::Menu/new>. Additionally, the paramhash's +L</title> defaults to the I<KEY>, and the L</sort_order> defaults to the +pre-existing child's sort order (if a C<KEY> is being over-written) or +the end of the list, if it is a new C<KEY>. + +If the paramhash contains a key called C<menu>, that will be used instead +of creating a new RT::Interface::Web::Menu. + + +=cut + +sub child { + my $self = shift; + my $key = shift; + my $proto = ref $self || $self; + + if ( my %args = @_ ) { + + # Clear children ordering cache + delete $self->{children_list}; + + my $child; + if ( $child = $args{menu} ) { + $child->parent($self); + } else { + $child = $proto->new( + { parent => $self, + key => $key, + title => $key, + escape_title=> 1, + %args + } + ); + } + $self->{children}{$key} = $child; + + $child->sort_order( $args{sort_order} || (scalar values %{ $self->{children} }) ) + unless ($child->sort_order()); + + # URL is relative to parents, and cached, so set it up now + $child->path( $child->{path} ); + + # Figure out the URL + my $path = $child->path; + + # Activate it + if ( defined $path and length $path ) { + my $base_path = $HTML::Mason::Commands::r->path_info; + my $query = $HTML::Mason::Commands::m->cgi_object->query_string; + $base_path .= "?$query" if defined $query and length $query; + + $base_path =~ s/index\.html$//; + $base_path =~ s/\/+$//; + $path =~ s/index\.html$//; + $path =~ s/\/+$//; + + if ( $path eq $base_path ) { + $self->{children}{$key}->active(1); + } + } + } + + return $self->{children}{$key}; +} + +=head2 active_child + +Returns the first active child node, or C<undef> is there is none. + +=cut + +sub active_child { + my $self = shift; + foreach my $kid ($self->children) { + return $kid if $kid->active; + } + return undef; +} + + +=head2 delete KEY + +Removes the child with the provided I<KEY>. + +=cut + +sub delete { + my $self = shift; + my $key = shift; + delete $self->{children_list}; + delete $self->{children}{$key}; +} + + +=head2 has_children + +Returns true if there are any children on this menu + +=cut + +sub has_children { + my $self = shift; + if (@{ $self->children}) { + return 1 + } else { + return 0; + } +} + + +=head2 children + +Returns the children of this menu item in sorted order; as an array in +array context, or as an array reference in scalar context. + +=cut + +sub children { my $self = shift; - return $self->{'root_node'}; + my @kids; + if ($self->{children_list}) { + @kids = @{$self->{children_list}}; + } else { + @kids = values %{$self->{children} || {}}; + @kids = sort {$a->{sort_order} <=> $b->{sort_order}} @kids; + $self->{children_list} = \@kids; + } + return wantarray ? @kids : \@kids; } 1; diff --git a/rt/lib/RT/Interface/Web/Menu/Item.pm b/rt/lib/RT/Interface/Web/Menu/Item.pm deleted file mode 100644 index 29fb13bcc..000000000 --- a/rt/lib/RT/Interface/Web/Menu/Item.pm +++ /dev/null @@ -1,88 +0,0 @@ -# BEGIN BPS TAGGED BLOCK {{{ -# -# COPYRIGHT: -# -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC -# <sales@bestpractical.com> -# -# (Except where explicitly superseded by other copyright notices) -# -# -# LICENSE: -# -# This work is made available to you under the terms of Version 2 of -# the GNU General Public License. A copy of that license should have -# been provided with this software, but in any event can be snarfed -# from www.gnu.org. -# -# This work is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -# 02110-1301 or visit their web page on the internet at -# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. -# -# -# CONTRIBUTION SUBMISSION POLICY: -# -# (The following paragraph is not intended to limit the rights granted -# to you to modify and distribute this software under the terms of -# the GNU General Public License and is only of importance to you if -# you choose to contribute your changes and enhancements to the -# community by submitting them to Best Practical Solutions, LLC.) -# -# By intentionally submitting any modifications, corrections or -# derivatives to this work, or any other work intended for use with -# Request Tracker, to Best Practical Solutions, LLC, you confirm that -# you are the copyright holder for those contributions and you grant -# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, -# royalty-free, perpetual, license to use, copy, create derivative -# works based on those contributions, and sublicense and distribute -# those contributions and any derivatives thereof. -# -# END BPS TAGGED BLOCK }}} - -package RT::Interface::Web::Menu::Item; -use strict; -use warnings; - -sub new { - my $class = shift; - my $self = bless {},$class; - $self->{'_attributes'} = {}; - return($self); -} - -sub label { my $self = shift; $self->_accessor( label => @_) } ; -sub absolute_url { my $self = shift; $self->_accessor( absolute_url => @_) } ; -sub rt_path { my $self = shift; $self->_accessor( rt_path => @_) } ; -sub hilight { my $self = shift; $self->_accessor( hilight => @_); - $self->parent->hilight(1); - } ; -sub sort_order { my $self = shift; $self->_accessor( sort_order => @_) } ; - -sub add_child { -} - -sub delete { -} - -sub children { - -} - -sub _accessor { - my $self = shift; - my $key = shift; - if (@_){ - $self->{'attributes'}->{$key} = shift; - - } - return $self->{'_attributes'}->{$key}; -} - -1; diff --git a/rt/lib/RT/Interface/Web/QueryBuilder.pm b/rt/lib/RT/Interface/Web/QueryBuilder.pm index 09b95398c..79a0b9718 100755 --- a/rt/lib/RT/Interface/Web/QueryBuilder.pm +++ b/rt/lib/RT/Interface/Web/QueryBuilder.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) diff --git a/rt/lib/RT/Interface/Web/QueryBuilder/Tree.pm b/rt/lib/RT/Interface/Web/QueryBuilder/Tree.pm index 493ab444d..2cfc88998 100755 --- a/rt/lib/RT/Interface/Web/QueryBuilder/Tree.pm +++ b/rt/lib/RT/Interface/Web/QueryBuilder/Tree.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -92,8 +92,8 @@ sub TraversePrePost { =head2 GetReferencedQueues -Returns a hash reference with keys each queue name referenced in a clause in -the key (even if it's "Queue != 'Foo'"), and values all 1. +Returns a hash reference; each queue referenced with an '=' operation +will appear as a key whose value is 1. =cut @@ -110,10 +110,12 @@ sub GetReferencedQueues { return unless $node->isLeaf; my $clause = $node->getNodeValue(); + return unless $clause->{Key} eq 'Queue'; + return unless $clause->{Op} eq '='; - if ( $clause->{Key} eq 'Queue' ) { - $queues->{ $clause->{Value} } = 1; - }; + my $value = $clause->{Value}; + $value =~ s/\\(.)/$1/g if $value =~ s/^'(.*)'$/$1/; + $queues->{ $value } = 1; } ); @@ -260,20 +262,24 @@ sub ParseSQL { my $class; if ( exists $lcfield{ lc $main_key } ) { - $class = $field{ $main_key }->[0]; $key =~ s/^[^.]+/ $lcfield{ lc $main_key } /e; + ($main_key) = split /[.]/, $key; # make the case right + $class = $field{ $main_key }->[0]; } unless( $class ) { push @results, [ $args{'CurrentUser'}->loc("Unknown field: [_1]", $key), -1 ] } - $value =~ s/'/\\'/g; if ( lc $op eq 'is' || lc $op eq 'is not' ) { $value = 'NULL'; # just fix possible mistakes here } elsif ( $value !~ /^[+-]?[0-9]+$/ ) { + $value =~ s/(['\\])/\\$1/g; $value = "'$value'"; } - $key = "'$key'" if $key =~ /^CF./; + + if ($key =~ s/(['\\])/\\$1/g or $key =~ /[^{}\w\.]/) { + $key = "'$key'"; + } my $clause = { Key => $key, Op => $op, Value => $value }; $node->addChild( __PACKAGE__->new( $clause ) ); diff --git a/rt/lib/RT/Interface/Web/Request.pm b/rt/lib/RT/Interface/Web/Request.pm index 84dd28dd6..d0865117d 100644 --- a/rt/lib/RT/Interface/Web/Request.pm +++ b/rt/lib/RT/Interface/Web/Request.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) @@ -52,51 +52,16 @@ use strict; use warnings; our $VERSION = '0.30'; -use base qw(HTML::Mason::Request); +use HTML::Mason::PSGIHandler; +use base qw(HTML::Mason::Request::PSGI); +use Params::Validate qw(:all); sub new { my $class = shift; - - my $new_class = $HTML::Mason::ApacheHandler::VERSION ? - 'HTML::Mason::Request::ApacheHandler' : - $HTML::Mason::CGIHandler::VERSION ? - 'HTML::Mason::Request::CGI' : - 'HTML::Mason::Request'; - - $class->alter_superclass( $new_class ); - $class->valid_params( %{ $new_class->valid_params } ); + $class->valid_params( %{ $class->valid_params },cgi_request => { type => OBJECT, optional => 1 } ); return $class->SUPER::new(@_); } -# XXX TODO: This alter_superclass replaces teh funcitonality in Mason 1.39 -# with code which doesn't trigger a bug in Perl 5.10. -# (Perl 5.10.0 does NOT take kindly to having its @INC entries changed) -# http://rt.perl.org/rt3/Public/Bug/Display.html?id=54566 -# -# This routine can be removed when either: -# * RT depends on a version of mason which contains this fix -# * Perl 5.10.0 is not supported for running RT -sub alter_superclass { - my $class = shift; - my $new_super = shift; - my $isa_ref; - { no strict 'refs'; my @entries = @{$class."::ISA"}; $isa_ref = \@entries; } - - # handles multiple inheritance properly and preserve - # inheritance order - for ( my $x = 0; $x <= $#{$isa_ref} ; $x++ ) { - if ( $isa_ref->[$x]->isa('HTML::Mason::Request') ) { - my $old_super = $isa_ref->[$x]; - $isa_ref->[$x] = $new_super - if ( $old_super ne $new_super ); - last; - } - } - - { no strict 'refs'; @{$class."::ISA"} = @$isa_ref; } - $class->valid_params( %{ $class->valid_params } ); -} - =head2 callback @@ -153,11 +118,7 @@ sub callback { unless ( $callbacks ) { $callbacks = []; my $path = "/Callbacks/*$page/$name"; - my @roots = map $_->[1], - $HTML::Mason::VERSION <= 1.28 - ? $self->interp->resolver->comp_root_array - : $self->interp->comp_root_array; - + my @roots = RT::Interface::Web->ComponentRoots; my %seen; @$callbacks = ( grep defined && length, diff --git a/rt/lib/RT/Interface/Web/Session.pm b/rt/lib/RT/Interface/Web/Session.pm index 8ce8afd2b..c5b88f127 100644 --- a/rt/lib/RT/Interface/Web/Session.pm +++ b/rt/lib/RT/Interface/Web/Session.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC # <sales@bestpractical.com> # # (Except where explicitly superseded by other copyright notices) diff --git a/rt/lib/RT/Interface/Web/Standalone.pm b/rt/lib/RT/Interface/Web/Standalone.pm deleted file mode 100755 index 3157e315e..000000000 --- a/rt/lib/RT/Interface/Web/Standalone.pm +++ /dev/null @@ -1,126 +0,0 @@ -# BEGIN BPS TAGGED BLOCK {{{ -# -# COPYRIGHT: -# -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC -# <sales@bestpractical.com> -# -# (Except where explicitly superseded by other copyright notices) -# -# -# LICENSE: -# -# This work is made available to you under the terms of Version 2 of -# the GNU General Public License. A copy of that license should have -# been provided with this software, but in any event can be snarfed -# from www.gnu.org. -# -# This work is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -# 02110-1301 or visit their web page on the internet at -# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. -# -# -# CONTRIBUTION SUBMISSION POLICY: -# -# (The following paragraph is not intended to limit the rights granted -# to you to modify and distribute this software under the terms of -# the GNU General Public License and is only of importance to you if -# you choose to contribute your changes and enhancements to the -# community by submitting them to Best Practical Solutions, LLC.) -# -# By intentionally submitting any modifications, corrections or -# derivatives to this work, or any other work intended for use with -# Request Tracker, to Best Practical Solutions, LLC, you confirm that -# you are the copyright holder for those contributions and you grant -# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, -# royalty-free, perpetual, license to use, copy, create derivative -# works based on those contributions, and sublicense and distribute -# those contributions and any derivatives thereof. -# -# END BPS TAGGED BLOCK }}} - -use strict; -use warnings; -package RT::Interface::Web::Standalone; - -use base 'HTTP::Server::Simple::Mason'; -use RT::Interface::Web::Handler; -use RT::Interface::Web; -use URI; - -sub handler_class { "RT::Interface::Web::Handler" } - -sub setup_escapes { - my $self = shift; - my $handler = shift; - - # Override HTTP::Server::Simple::Mason's version of this method to do - # nothing. (RT::Interface::Web::Handler does this already for us in - # NewHandler.) -} - -sub default_mason_config { - return RT->Config->Get('MasonParameters'); -} - -sub handle_request { - - my $self = shift; - my $cgi = shift; - - Module::Refresh->refresh if RT->Config->Get('DevelMode'); - RT::ConnectToDatabase() unless RT->InstallMode; - - # Each environment has its own way of handling .. and so on in paths, - # so RT consistently forbids such paths. - if ( $cgi->path_info =~ m{/\.} ) { - $RT::Logger->crit("Invalid request for ".$cgi->path_info." aborting"); - print STDOUT "HTTP/1.0 400\r\n\r\n"; - return RT::Interface::Web::Handler->CleanupRequest(); - } - - $self->SUPER::handle_request($cgi); - $RT::Logger->crit($@) if $@ && $RT::Logger; - warn $@ if $@ && !$RT::Logger; - RT::Interface::Web::Handler->CleanupRequest(); -} - -sub net_server { - my $self = shift; - $self->{rt_net_server} = shift if @_; - return $self->{rt_net_server}; -} - - -=head2 print_banner - -This routine prints a banner before the server request-handling loop -starts. - -Methods below this point are probably not terribly useful to define -yourself in subclasses. - -=cut - -sub print_banner { - my $self = shift; - - my $url = URI->new( RT->Config->Get('WebBaseURL')); - $url->host('127.0.0.1') if ($url->host() eq 'localhost'); - $url->port($self->port); - print( - "You can connect to your server at " - . $url->canonical - . "\n" ); - -} - - -1; diff --git a/rt/lib/RT/Interface/Web/Standalone/PreFork.pm b/rt/lib/RT/Interface/Web/Standalone/PreFork.pm deleted file mode 100644 index f569e4f00..000000000 --- a/rt/lib/RT/Interface/Web/Standalone/PreFork.pm +++ /dev/null @@ -1,103 +0,0 @@ -# BEGIN BPS TAGGED BLOCK {{{ -# -# COPYRIGHT: -# -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC -# <sales@bestpractical.com> -# -# (Except where explicitly superseded by other copyright notices) -# -# -# LICENSE: -# -# This work is made available to you under the terms of Version 2 of -# the GNU General Public License. A copy of that license should have -# been provided with this software, but in any event can be snarfed -# from www.gnu.org. -# -# This work is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -# 02110-1301 or visit their web page on the internet at -# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. -# -# -# CONTRIBUTION SUBMISSION POLICY: -# -# (The following paragraph is not intended to limit the rights granted -# to you to modify and distribute this software under the terms of -# the GNU General Public License and is only of importance to you if -# you choose to contribute your changes and enhancements to the -# community by submitting them to Best Practical Solutions, LLC.) -# -# By intentionally submitting any modifications, corrections or -# derivatives to this work, or any other work intended for use with -# Request Tracker, to Best Practical Solutions, LLC, you confirm that -# you are the copyright holder for those contributions and you grant -# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, -# royalty-free, perpetual, license to use, copy, create derivative -# works based on those contributions, and sublicense and distribute -# those contributions and any derivatives thereof. -# -# END BPS TAGGED BLOCK }}} - -use warnings; -use strict; - -package RT::Interface::Web::Standalone::PreFork; -use base qw/Net::Server::PreFork/; - -my %option_map = ( - min_servers => 'StandaloneMinServers', - max_servers => 'StandaloneMaxServers', - min_spare_servers => 'StandaloneMinSpareServers', - max_spare_servers => 'StandaloneMaxSpareServers', - max_requests => 'StandaloneMaxRequests', -); - -=head2 default_values - -Produces the default values for L<Net::Server> configuration from RT's config -files. - -=cut - -sub default_values { - my %forking = ( - map { $_ => RT->Config->Get( $option_map{$_} ) } - grep { defined( RT->Config->Get( $option_map{$_} ) ) } - keys %option_map, - ); - - return { - %forking, - log_level => 1, - RT->Config->Get('NetServerOptions') - }; -} - -=head2 post_bind_hook - -After binding to the specified ports, let the user know that the server is -prepared to handle connections. - -=cut - -sub post_bind_hook { - my $self = shift; - my @ports = @{ $self->{server}->{port} }; - - print $0 - . ": You can connect to your server at " - . (join ' , ', map { "http://localhost:$_/" } @ports) - . "\n"; - - $self->SUPER::post_bind_hook(@_); -} - -1; |