Master to 4.2.8
[usit-rt.git] / lib / RT / Interface / Web.pm
index 0aebeed..a2fa00f 100644 (file)
@@ -68,9 +68,9 @@ 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();
+use Plack::Util;
 
 =head2 SquishedCSS $style
 
@@ -105,7 +105,7 @@ sub SquishedJS {
 =cut
 
 sub JSFiles {
-    return qw/
+    return qw{
       jquery-1.9.1.min.js
       jquery_noconflict.js
       jquery-ui-1.10.0.custom.min.js
@@ -127,7 +127,8 @@ sub JSFiles {
       forms.js
       event-registration.js
       late.js
-      /, RT->Config->Get('JSFiles');
+      /static/RichText/ckeditor.js
+      }, RT->Config->Get('JSFiles');
 }
 
 =head2 ClearSquished
@@ -704,11 +705,6 @@ sub AttemptExternalAuth {
         $user = RT::Interface::Web::WebCanonicalizeInfo();
         my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load';
 
-        if ( $^O eq 'MSWin32' and RT->Config->Get('WebRemoteUserGecos') ) {
-            my $NodeName = Win32::NodeName();
-            $user =~ s/^\Q$NodeName\E\\//i;
-        }
-
         my $next = RemoveNextPage($ARGS->{'next'});
            $next = $next->{'url'} if ref $next;
         InstantiateNewSession() unless _UserLoggedIn;
@@ -826,7 +822,7 @@ sub AttemptPasswordAuthentication {
         InstantiateNewSession();
         $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
 
-        $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
+        $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next );
 
         # Really the only time we don't want to redirect here is if we were
         # passed user and pass as query params in the URL.
@@ -965,13 +961,13 @@ sub Redirect {
     $HTML::Mason::Commands::m->abort;
 }
 
-=head2 CacheControlExpiresHeaders
+=head2 GetStaticHeaders
 
-set both Cache-Control and Expires http headers
+return an arrayref of Headers (currently, Cache-Control and Expires).
 
 =cut
 
-sub CacheControlExpiresHeaders {
+sub GetStaticHeaders {
     my %args = @_;
 
     my $Visibility = 'private';
@@ -988,13 +984,28 @@ sub CacheControlExpiresHeaders {
         ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
         : 'no-cache'
     ;
-    $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
 
     my $expires = RT::Date->new(RT->SystemUser);
     $expires->SetToNow;
     $expires->AddSeconds( $args{Time} ) if $args{Time};
 
-    $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
+    return [
+        Expires => $expires->RFC2616,
+        'Cache-Control' => $CacheControl,
+    ];
+}
+
+=head2 CacheControlExpiresHeaders
+
+set both Cache-Control and Expires http headers
+
+=cut
+
+sub CacheControlExpiresHeaders {
+    Plack::Util::header_iter( GetStaticHeaders(@_), sub {
+        my ( $key, $val ) = @_;
+        $HTML::Mason::Commands::r->headers_out->{$key} = $val;
+    } );
 }
 
 =head2 StaticFileHeaders 
@@ -1007,20 +1018,12 @@ This routine could really use _accurate_ heuristics. (XXX TODO)
 =cut
 
 sub StaticFileHeaders {
-    my $date = RT::Date->new(RT->SystemUser);
-
     # 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.
     CacheControlExpiresHeaders( Time => 'forever' );
-
-    # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
-    # request, but we don't handle it and generate full reply again
-    # Last modified at server start time
-    # $date->Set( Value => $^T );
-    # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
 }
 
 =head2 ComponentPathIsSafe PATH
@@ -1036,7 +1039,7 @@ not contain a slash-dot C</.>, and does not contain any nulls.
 sub ComponentPathIsSafe {
     my $self = shift;
     my $path = shift;
-    return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
+    return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
 }
 
 =head2 PathIsSafe
@@ -1201,21 +1204,25 @@ sub StripContent {
 sub DecodeARGS {
     my $ARGS = shift;
 
+    # Later in the code we use
+    # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
+    # instead of $m->call_next to avoid problems with UTF8 keys in
+    # arguments.  Specifically, the call_next method pass through
+    # original arguments, which are still the encoded bytes, not
+    # characters.  "{ base_comp => $m->request_comp }" is copied from
+    # mason's source to get the same results as we get from call_next
+    # method; this feature is not documented.
     %{$ARGS} = map {
 
         # if they've passed multiple values, they'll be an array. if they've
         # passed just one, a scalar whatever they are, mark them as utf8
         my $type = ref($_);
         ( !$type )
-            ? Encode::is_utf8($_)
-                ? $_
-                : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
+            ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
             : ( $type eq 'ARRAY' )
-            ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
-                @$_ ]
+            ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
             : ( $type eq 'HASH' )
-            ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
-                %$_ }
+            ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
             : $_
     } %$ARGS;
 }
@@ -1223,17 +1230,6 @@ sub DecodeARGS {
 sub PreprocessTimeUpdates {
     my $ARGS = shift;
 
-    # Later in the code we use
-    # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
-    # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
-    # The call_next method pass through original arguments and if you have
-    # an argument with unicode key then in a next component you'll get two
-    # records in the args hash: one with key without UTF8 flag and another
-    # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
-    # is copied from mason's source to get the same results as we get from
-    # call_next method, this feature is not documented, so we just leave it
-    # here to avoid possible side effects.
-
     # This code canonicalizes time inputs in hours into minutes
     foreach my $field ( keys %$ARGS ) {
         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
@@ -1372,6 +1368,7 @@ our %is_whitelisted_component = (
     '/Search/Simple.html'  => 1,
     '/m/tickets/search'    => 1,
     '/Search/Chart.html'   => 1,
+    '/User/Search.html'    => 1,
 
     # This page takes Attachment and Transaction argument to figure
     # out what to show, but it's read only and will deny information if you
@@ -1573,8 +1570,12 @@ sub StoreRequestToken {
     if ($ARGS->{Attach}) {
         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
         my $file_path = delete $ARGS->{'Attach'};
+
+        # This needs to be decoded because the value is a reference;
+        # hence it was not decoded along with all of the standard
+        # arguments in DecodeARGS
         $data->{attach} = {
-            filename => Encode::decode_utf8("$file_path"),
+            filename => Encode::decode("UTF-8", "$file_path"),
             mime     => $attachment,
         };
     }
@@ -1716,6 +1717,89 @@ sub RewriteInlineImages {
     return @rewritten;
 }
 
+=head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
+
+Returns the standard custom field input name; this is complementary to
+L</_ParseObjectCustomFieldArgs>.  Takes the following arguments:
+
+=over
+
+=item CustomField => I<L<RT::CustomField> object>
+
+Required.
+
+=item Object => I<object>
+
+The object that the custom field is applied to; optional.  If omitted,
+defaults to a new object of the appropriate class for the custom field.
+
+=item Grouping => I<CF grouping>
+
+The grouping that the custom field is being rendered in.  Groupings
+allow a custom field to appear in more than one location per form.
+
+=back
+
+=cut
+
+sub GetCustomFieldInputName {
+    my %args = (
+        CustomField => undef,
+        Object      => undef,
+        Grouping    => undef,
+        @_,
+    );
+
+    my $name = GetCustomFieldInputNamePrefix(%args);
+
+    if ( $args{CustomField}->Type eq 'Select' ) {
+        if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
+            $name .= 'Value';
+        }
+        else {
+            $name .= 'Values';
+        }
+    }
+    elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
+        $name .= 'Upload';
+    }
+    elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
+        $name .= 'Values';
+    }
+    else {
+        if ( $args{CustomField}->SingleValue ) {
+            $name .= 'Value';
+        }
+        else {
+            $name .= 'Values';
+        }
+    }
+
+    return $name;
+}
+
+=head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
+
+Returns the standard custom field input name prefix(without "Value" or alike suffix)
+
+=cut
+
+sub GetCustomFieldInputNamePrefix {
+    my %args = (
+        CustomField => undef,
+        Object      => undef,
+        Grouping    => undef,
+        @_,
+    );
+
+    my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
+        ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
+        'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
+        $args{CustomField}->id, '';
+
+    return $prefix;
+}
+
 package HTML::Mason::Commands;
 
 use vars qw/$r $m %session/;
@@ -2207,7 +2291,7 @@ sub ProcessUpdateMessage {
         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
     );
 
-    $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
+    $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
     ) );
     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
@@ -2341,7 +2425,10 @@ sub ProcessAttachments {
             AttachmentFieldName => 'Attach'
         );
 
-        my $file_path = Encode::decode_utf8("$new");
+        # This needs to be decoded because the value is a reference;
+        # hence it was not decoded along with all of the standard
+        # arguments in DecodeARGS
+        my $file_path = Encode::decode( "UTF-8", "$new");
         $session{'Attachments'}{ $token }{ $file_path } = $attachment;
 
         $update_session = 1;
@@ -2375,9 +2462,9 @@ sub MakeMIMEEntity {
     );
     my $Message = MIME::Entity->build(
         Type    => 'multipart/mixed',
-        "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
+        "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
         "X-RT-Interface" => $args{Interface},
-        map { $_ => Encode::encode_utf8( $args{ $_} ) }
+        map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
             grep defined $args{$_}, qw(Subject From Cc)
     );
 
@@ -2389,7 +2476,7 @@ sub MakeMIMEEntity {
         $Message->attach(
             Type    => $args{'Type'} || 'text/plain',
             Charset => 'UTF-8',
-            Data    => $args{'Body'},
+            Data    => Encode::encode( "UTF-8", $args{'Body'} ),
         );
     }
 
@@ -2406,16 +2493,16 @@ sub MakeMIMEEntity {
 
             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
 
-            my $filename = "$filehandle";
+            my $filename = Encode::decode("UTF-8","$filehandle");
             $filename =~ s{^.*[\\/]}{};
 
             $Message->attach(
                 Type     => $uploadinfo->{'Content-Type'},
-                Filename => $filename,
-                Data     => \@content,
+                Filename => Encode::encode("UTF-8",$filename),
+                Data     => \@content, # Bytes, as read directly from the file, above
             );
             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
-                $Message->head->set( 'Subject' => $filename );
+                $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
             }
 
             # Attachment parts really shouldn't get a Message-ID or "interface"
@@ -2881,9 +2968,7 @@ sub ProcessTicketReminders {
                     Format => 'unknown',
                     Value  => $due,
                 );
-                if ( defined $DateObj->Unix
-                    && $DateObj->Unix != $reminder->DueObj->Unix )
-                {
+                if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
                     ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
                 }
                 else {
@@ -2970,13 +3055,14 @@ sub ProcessObjectCustomFieldUpdates {
                 }
                 push @results,
                     _ProcessObjectCustomFieldUpdates(
-                    # XXX FIXME: Prefix is not quite right, as $id almost
-                    # certainly started as blank for new objects and is now 0.
-                    # Only Image/Binary CFs on new objects should be affected.
-                    Prefix      => "Object-$class-$id-CustomField-$cf-",
-                    Object      => $Object,
-                    CustomField => $CustomFieldObj,
-                    ARGS        => $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]},
+                        Prefix => GetCustomFieldInputNamePrefix(
+                            Object      => $Object,
+                            CustomField => $CustomFieldObj,
+                            Grouping    => $groupings[0],
+                        ),
+                        Object      => $Object,
+                        CustomField => $CustomFieldObj,
+                        ARGS        => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
                     );
             }
         }
@@ -2991,6 +3077,7 @@ sub _ParseObjectCustomFieldArgs {
     foreach my $arg ( keys %$ARGSRef ) {
 
         # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
+        # you can use GetCustomFieldInputName to generate the complement input name
         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/;
 
         # For each of those objects, find out what custom fields we want to work with.
@@ -3010,7 +3097,7 @@ sub _ProcessObjectCustomFieldUpdates {
     # the browser gives you a blank value which causes CFs to be processed twice
     if (   defined $args{'ARGS'}->{'Values'}
         && !length $args{'ARGS'}->{'Values'}
-        && $args{'ARGS'}->{'Values-Magic'} )
+        && ($args{'ARGS'}->{'Values-Magic'}) )
     {
         delete $args{'ARGS'}->{'Values'};
     }
@@ -3019,11 +3106,11 @@ sub _ProcessObjectCustomFieldUpdates {
     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
 
         # skip category argument
-        next if $arg eq 'Category';
+        next if $arg =~ /-Category$/;
 
         # since http won't pass in a form element with a null value, we need
         # to fake it
-        if ( $arg eq 'Values-Magic' ) {
+        if ( $arg =~ /-Magic$/ ) {
 
             # We don't care about the magic, if there's really a values element;
             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
@@ -3163,16 +3250,21 @@ sub ProcessObjectCustomFieldUpdatesForCreate {
             }
 
             my @values;
+            my $name_prefix = GetCustomFieldInputNamePrefix(
+                CustomField => $cf,
+                Grouping    => $groupings[0],
+            );
             while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
                 # Values-Magic doesn't matter on create; no previous values are being removed
                 # Category is irrelevant for the actual value
-                next if $arg eq "Values-Magic" or $arg eq "Category";
+                next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
 
-                push @values, _NormalizeObjectCustomFieldValue(
+                push @values,
+                    _NormalizeObjectCustomFieldValue(
                     CustomField => $cf,
-                    Param       => "Object-$class--CustomField-$cfid-$arg",
+                    Param       => $name_prefix . $arg,
                     Value       => $value,
-                );
+                    );
             }
 
             $parsed{"CustomField-$cfid"} = \@values if @values;
@@ -3335,9 +3427,7 @@ sub ProcessTicketDates {
         );
 
         my $obj = $field . "Obj";
-        if (    ( defined $DateObj->Unix )
-            and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
-        {
+        if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
             my $method = "Set$field";
             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
             push @results, "$msg";
@@ -3519,7 +3609,7 @@ sub ProcessRecordBulkCustomFields {
     foreach my $key ( keys %$ARGSRef ) {
         next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
         my ($op, $cfid, $rest) = ($1, $2, $3);
-        next if $rest eq "Category";
+        next if $rest =~ /-Category$/;
 
         my $res = $data{$cfid} ||= {};
         unless (keys %$res) {
@@ -3545,8 +3635,12 @@ sub ProcessRecordBulkCustomFields {
     }
 
     while ( my ($cfid, $data) = each %data ) {
+        my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
+
         # just add one value for fields with single value
         if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
+            next if $current_values->HasEntry($data->{Add}[-1]);
+
             my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
                 Field => $cfid,
                 Value => $data->{'Add'}[-1],
@@ -3555,7 +3649,6 @@ sub ProcessRecordBulkCustomFields {
             next;
         }
 
-        my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
         if ( $data->{'DeleteAll'} ) {
             while ( my $value = $current_values->Next ) {
                 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
@@ -3566,11 +3659,12 @@ sub ProcessRecordBulkCustomFields {
             }
         }
         foreach my $value ( @{ $data->{'Delete'} || [] } ) {
-            next unless $current_values->HasEntry($value);
+            my $entry = $current_values->HasEntry($value);
+            next unless $entry;
 
             my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
-                Field => $cfid,
-                Value => $value
+                Field   => $cfid,
+                ValueId => $entry->id,
             );
             push @results, $msg;
         }
@@ -3823,6 +3917,7 @@ our %SCRUBBER_ALLOWED_ATTRIBUTES = (
     href   => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
     face   => 1,
     size   => 1,
+    color  => 1,
     target => 1,
     style  => qr{
         ^(?:\s*
@@ -3836,6 +3931,12 @@ our %SCRUBBER_ALLOWED_ATTRIBUTES = (
                font-family: \s* [\w\s"',.\-]+       |
                font-weight: \s* [\w\-]+             |
 
+               border-style: \s* \w+                |
+               border-color: \s* [#\w]+             |
+               border-width: \s* [\s\w]+            |
+               padding: \s* [\s\w]+                 |
+               margin: \s* [\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"',.\-]+
@@ -3868,6 +3969,22 @@ if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImage
 sub _NewScrubber {
     require HTML::Scrubber;
     my $scrubber = HTML::Scrubber->new();
+
+    if (HTML::Gumbo->require) {
+        no warnings 'redefine';
+        my $orig = \&HTML::Scrubber::scrub;
+        *HTML::Scrubber::scrub = sub {
+            my $self = shift;
+
+            eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
+            warn "HTML::Gumbo pre-parse failed: $@" if $@;
+            return $orig->($self, @_);
+        };
+        push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
+        $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
+            qw/colspan rowspan align valign cellspacing cellpadding border width height/;
+    }
+
     $scrubber->default(
         0,
         {
@@ -3903,6 +4020,14 @@ sub CSSClass {
     return $value;
 }
 
+sub GetCustomFieldInputName {
+    RT::Interface::Web::GetCustomFieldInputName(@_);
+}
+
+sub GetCustomFieldInputNamePrefix {
+    RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
+}
+
 package RT::Interface::Web;
 RT::Base->_ImportOverlays();