rt/lib/RT/Interface/REST.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2016 Best Practical Solutions, LLC
   6 #                                          <sales@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 package RT::Interface::REST;
  50 use LWP::MediaTypes qw(guess_media_type);
  51 use strict;
  52 use warnings;
  53 use RT;
  54
  55 use base 'Exporter';
  56 our @EXPORT = qw(expand_list form_parse form_compose vpush vsplit process_attachments);
  57
  58 sub custom_field_spec {
  59     my $self    = shift;
  60     my $capture = shift;
  61
  62     my $CF_name = '[^,]+';
  63     $CF_name = '(' . $CF_name . ')' if $capture;
  64
  65     my $new_style = 'CF\.\{'.$CF_name.'\}';
  66     my $old_style = 'C(?:ustom)?F(?:ield)?-'.$CF_name;
  67
  68     return '(?i:' . join('|', $new_style, $old_style) . ')';
  69 }
  70
  71 sub field_spec {
  72     my $self    = shift;
  73     my $capture = shift;
  74
  75     my $field = '[a-z][a-z0-9_-]*';
  76     $field = '(' . $field . ')' if $capture;
  77
  78     my $custom_field = __PACKAGE__->custom_field_spec($capture);
  79
  80     return '(?i:' . join('|', $field, $custom_field) . ')';
  81 }
  82
  83 # WARN: this code is duplicated in bin/rt.in,
  84 # change both functions at once
  85 sub expand_list {
  86     my ($list) = @_;
  87
  88     my @elts;
  89     foreach (split /\s*,\s*/, $list) {
  90         push @elts, /^(\d+)-(\d+)$/? ($1..$2): $_;
  91     }
  92
  93     return map $_->[0], # schwartzian transform
  94         sort {
  95             defined $a->[1] && defined $b->[1]?
  96                 # both numbers
  97                 $a->[1] <=> $b->[1]
  98                 :!defined $a->[1] && !defined $b->[1]?
  99                     # both letters
 100                     $a->[2] cmp $b->[2]
 101                     # mix, number must be first
 102                     :defined $a->[1]? -1: 1
 103         }
 104         map [ $_, (defined( /^(\d+)$/ )? $1: undef), lc($_) ],
 105         @elts;
 106 }
 107
 108 # Returns a reference to an array of parsed forms.
 109 sub form_parse {
 110     my $state = 0;
 111     my @forms = ();
 112     my @lines = split /\n/, $_[0];
 113     my ($c, $o, $k, $e) = ("", [], {}, "");
 114     my $field = __PACKAGE__->field_spec;
 115
 116     LINE:
 117     while (@lines) {
 118         my $line = shift @lines;
 119
 120         next LINE if $line eq '';
 121
 122         if ($line eq '--') {
 123             # We reached the end of one form. We'll ignore it if it was
 124             # empty, and store it otherwise, errors and all.
 125             if ($e || $c || @$o) {
 126                 push @forms, [ $c, $o, $k, $e ];
 127                 $c = ""; $o = []; $k = {}; $e = "";
 128             }
 129             $state = 0;
 130         }
 131         elsif ($state != -1) {
 132             if ($state == 0 && $line =~ /^#/) {
 133                 # Read an optional block of comments (only) at the start
 134                 # of the form.
 135                 $state = 1;
 136                 $c = $line;
 137                 while (@lines && $lines[0] =~ /^#/) {
 138                     $c .= "\n".shift @lines;
 139                 }
 140                 $c .= "\n";
 141             }
 142             elsif ($state <= 1 && $line =~ /^($field):(?:\s+(.*))?$/i) {
 143                 # Read a field: value specification.
 144                 my $f  = $1;
 145                 my @v  = ($2);
 146                 $v[0] = '' unless defined $v[0];
 147
 148                 # Read continuation lines, if any.
 149                 while (@lines && ($lines[0] eq '' || $lines[0] =~ /^\s+/)) {
 150                     push @v, shift @lines;
 151                 }
 152                 pop @v while (@v && $v[-1] eq '');
 153
 154                 # Strip longest common leading indent from text.
 155                 my $ws = ("");
 156                 foreach my $ls (map {/^(\s+)/} @v[1..$#v]) {
 157                     $ws = $ls if (!$ws || length($ls) < length($ws));
 158                 }
 159                 s/^$ws// foreach @v;
 160
 161                 shift @v while (@v && $v[0] eq '');
 162
 163                 push(@$o, $f) unless exists $k->{$f};
 164                 vpush($k, $f, join("\n", @v));
 165
 166                 $state = 1;
 167             }
 168             elsif ($line =~ /^#/) {
 169                 # We've found a syntax error, so we'll reconstruct the
 170                 # form parsed thus far, and add an error marker. (>>)
 171                 $state = -1;
 172                 $e = form_compose([[ "", $o, $k, "" ]]);
 173                 $e.= $line =~ /^>>/ ? "$line\n" : ">> $line\n";
 174             }
 175         }
 176         else {
 177             # We saw a syntax error earlier, so we'll accumulate the
 178             # contents of this form until the end.
 179             $e .= "$line\n";
 180         }
 181     }
 182     push(@forms, [ $c, $o, $k, $e ]) if ($e || $c || @$o);
 183
 184     foreach my $l (keys %$k) {
 185         $k->{$l} = vsplit($k->{$l}) if (ref $k->{$l} eq 'ARRAY');
 186     }
 187
 188     return \@forms;
 189 }
 190
 191 # Returns text representing a set of forms.
 192 sub form_compose {
 193     my ($forms) = @_;
 194     my (@text);
 195
 196     foreach my $form (@$forms) {
 197         my ($c, $o, $k, $e) = @$form;
 198         my $text = "";
 199
 200         if ($c) {
 201             $c =~ s/\n*$/\n/;
 202             $text = "$c\n";
 203         }
 204         if ($e) {
 205             $text .= $e;
 206         }
 207         elsif ($o) {
 208             my (@lines);
 209
 210             foreach my $key (@$o) {
 211                 my ($line, $sp);
 212                 my @values = (ref $k->{$key} eq 'ARRAY') ?
 213                                @{ $k->{$key} } :
 214                                   $k->{$key};
 215
 216                 $sp = " "x(length("$key: "));
 217                 $sp = " "x4 if length($sp) > 16;
 218
 219                 foreach my $v (@values) {
 220                     $v = '' unless defined $v;
 221                     if ( $v =~ /\n/) {
 222                         $v =~ s/^/$sp/gm;
 223                         $v =~ s/^$sp//;
 224
 225                         if ($line) {
 226                             push @lines, "$line\n\n";
 227                             $line = "";
 228                         }
 229                         elsif (@lines && $lines[-1] !~ /\n\n$/) {
 230                             $lines[-1] .= "\n";
 231                         }
 232                         push @lines, "$key: $v\n\n";
 233                     }
 234                     elsif ($line &&
 235                            length($line)+length($v)-rindex($line, "\n") >= 70)
 236                     {
 237                         $line .= ",\n$sp$v";
 238                     }
 239                     else {
 240                         $line = $line ? "$line, $v" : "$key: $v";
 241                     }
 242                 }
 243
 244                 $line = "$key:" unless @values;
 245                 if ($line) {
 246                     if ($line =~ /\n/) {
 247                         if (@lines && $lines[-1] !~ /\n\n$/) {
 248                             $lines[-1] .= "\n";
 249                         }
 250                         $line .= "\n";
 251                     }
 252                     push @lines, "$line\n";
 253                 }
 254             }
 255
 256             $text .= join "", @lines;
 257         }
 258         else {
 259             chomp $text;
 260         }
 261         push @text, $text;
 262     }
 263
 264     return join "\n--\n\n", @text;
 265 }
 266
 267 # Add a value to a (possibly multi-valued) hash key.
 268 sub vpush {
 269     my ($hash, $key, $val) = @_;
 270     my @val = ref $val eq 'ARRAY' ? @$val : $val;
 271
 272     if (exists $hash->{$key}) {
 273         unless (ref $hash->{$key} eq 'ARRAY') {
 274             my @v = $hash->{$key} ne '' ? $hash->{$key} : ();
 275             $hash->{$key} = \@v;
 276         }
 277         push @{ $hash->{$key} }, @val;
 278     }
 279     else {
 280         $hash->{$key} = $val;
 281     }
 282 }
 283
 284 # "Normalise" a hash key that's known to be multi-valued.
 285 sub vsplit {
 286     my ($val, $strip) = @_;
 287     my @words;
 288     my @values = map {split /\n/} (ref $val eq 'ARRAY' ? @$val : $val);
 289
 290     foreach my $line (@values) {
 291         while ($line =~ /\S/) {
 292             $line =~ s/^
 293                        \s*   # Trim leading whitespace
 294                        (?:
 295                            (")   # Quoted string
 296                            ((?>[^\\"]*(?:\\.[^\\"]*)*))"
 297                        |
 298                            (')   # Single-quoted string
 299                            ((?>[^\\']*(?:\\.[^\\']*)*))'
 300                        |
 301                            q\{(.*?)\}  # A perl-ish q{} string; this does
 302                                      # no paren balancing, however, and
 303                                      # only exists for back-compat
 304                        |
 305                            (.*?)     # Anything else, until the next comma
 306                        )
 307                        \s*   # Trim trailing whitespace
 308                        (?:
 309                            \Z  # Finish at end-of-line
 310                        |
 311                            ,   # Or a comma
 312                        )
 313                       //xs or last; # There should be no way this match
 314                                     # fails, but add a failsafe to
 315                                     # prevent infinite-looping if it
 316                                     # somehow does.
 317             my ($quote, $quoted) = ($1 ? ($1, $2) : $3 ? ($3, $4) : ('', $5 || $6));
 318             # Only unquote the quote character, or the backslash -- and
 319             # only if we were originally quoted..
 320             if ($5) {
 321                 $quoted =~ s/([\\'])/\\$1/g;
 322                 $quote = "'";
 323             }
 324             if ($strip) {
 325                 $quoted =~ s/\\([\\$quote])/$1/g if $quote;
 326                 push @words, $quoted;
 327             } else {
 328                 push @words, "$quote$quoted$quote";
 329             }
 330         }
 331     }
 332     return \@words;
 333 }
 334
 335 sub process_attachments {
 336     my $entity = shift;
 337     my @list = @_;
 338     return 1 unless @list;
 339
 340     my $m = $HTML::Mason::Commands::m;
 341     my $cgi = $m->cgi_object;
 342
 343     my $i = 1;
 344     foreach my $e ( @list ) {
 345
 346         my $fh = $cgi->upload("attachment_$i");
 347         return (0, "No attachment for $e") unless $fh;
 348
 349         local $/=undef;
 350
 351         my $file = $e;
 352         $file =~ s#^.*[\\/]##;
 353
 354         my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
 355
 356         my $buf;
 357         while (sysread($fh, $buf, 8192)) {
 358             syswrite($tmp_fh, $buf);
 359         }
 360
 361         my $info = $cgi->uploadInfo($fh);
 362         # If Content-ID exists for attachment then we need multipart/related
 363         # to be able to refer to this Content-Id in core of mime message
 364         if($info->{'Content-ID'}) {
 365             $entity->head->set('Content-Type', 'multipart/related');
 366         }
 367         my $new_entity = $entity->attach(
 368             Path => $tmp_fn,
 369             Type => $info->{'Content-Type'} || guess_media_type($tmp_fn),
 370             Filename => $file,
 371             Disposition => $info->{'Content-Disposition'} || "attachment",
 372             'Content-ID' => $info->{'Content-ID'},
 373         );
 374         $new_entity->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh;
 375         $i++;
 376     }
 377     return (1);
 378 }
 379
 380 RT::Base->_ImportOverlays();
 381
 382 1;
 383
 384 =head1 NAME
 385
 386   RT::Interface::REST - helper functions for the REST interface.
 387
 388 =head1 SYNOPSIS
 389
 390   Only the REST should use this module.