SL/Request.pm

   1 package SL::Request;
   2
   3 use strict;
   4
   5 use parent qw(Rose::Object);
   6
   7 use CGI qw(-no_xhtml);
   8 use List::Util qw(first max min sum);
   9 use List::MoreUtils qw(all any apply);
  10 use Exporter qw(import);
  11
  12 use SL::Common;
  13 use SL::MoreCommon qw(uri_encode uri_decode);
  14 use SL::Layout::None;
  15 use SL::Presenter;
  16
  17 our @EXPORT_OK = qw(flatten unflatten read_cgi_input);
  18
  19 use Rose::Object::MakeMethods::Generic
  20 (
  21   scalar                  => [ qw(applying_database_upgrades) ],
  22   'scalar --get_set_init' => [ qw(cgi layout presenter is_ajax type) ],
  23 );
  24
  25 sub init_cgi {
  26   return CGI->new({});
  27 }
  28
  29 sub init_layout {
  30   return SL::Layout::None->new;
  31 }
  32
  33 sub init_presenter {
  34   return SL::Presenter->new;
  35 }
  36
  37 sub init_is_ajax {
  38   return ($ENV{HTTP_X_REQUESTED_WITH} || '') eq 'XMLHttpRequest' ? 1 : 0;
  39 }
  40
  41 sub init_type {
  42   return 'html';
  43 }
  44
  45 sub is_https {
  46   $ENV{HTTPS} && 'on' eq lc $ENV{HTTPS};
  47 }
  48
  49 sub cache {
  50   my ($self, $topic, $default) = @_;
  51
  52   $topic = '::' . (caller(0))[0] . "::$topic" unless $topic =~ m{^::};
  53
  54   $self->{_cache}           //= {};
  55   $self->{_cache}->{$topic} //= ($default // {});
  56
  57   return $self->{_cache}->{$topic};
  58 }
  59
  60 sub _store_value {
  61   my ($target, $key, $value) = @_;
  62   my @tokens = split /((?:\[\+?\])?(?:\.)|(?:\[\+?\]))/, $key;
  63   my $curr;
  64
  65   if (scalar @tokens) {
  66      $curr = \ $target->{ shift @tokens };
  67   }
  68
  69   while (@tokens) {
  70     my $sep = shift @tokens;
  71     my $key = shift @tokens;
  72
  73     $curr = \ $$curr->[$#$$curr], next   if $sep eq '[]' && @tokens;
  74     $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]' && !@tokens;
  75     $curr = \ $$curr->[++$#$$curr], next if $sep eq '[+]';
  76     $curr = \ $$curr->[max 0, $#$$curr]  if $sep eq '[].';
  77     $curr = \ $$curr->[++$#$$curr]       if $sep eq '[+].';
  78     $curr = \ $$curr->{$key}
  79   }
  80
  81   $$curr = $value;
  82
  83   return $curr;
  84 }
  85
  86 sub _input_to_hash {
  87   $::lxdebug->enter_sub(2);
  88
  89   my ($target, $input, $log) = @_;
  90   my @pairs = split(/&/, $input);
  91
  92   foreach (@pairs) {
  93     my ($key, $value) = split(/=/, $_, 2);
  94     next unless $key;
  95     _store_value($target, uri_decode($key), uri_decode($value));
  96
  97     # for debugging
  98     $::lxdebug->add_request_params(uri_decode($key) => uri_decode($value)) if $log;
  99   }
 100
 101   $::lxdebug->leave_sub(2);
 102 }
 103
 104 sub _parse_multipart_formdata {
 105   my ($target, $temp_target, $input, $log) = @_;
 106   my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous, $p_attachment, $encoding, $transfer_encoding);
 107   my $data_start = 0;
 108
 109   # teach substr and length to use good ol' bytes, not 'em fancy characters
 110   use bytes;
 111
 112   # We SHOULD honor encodings and transfer-encodings here, but as hard as I
 113   # looked I couldn't find a reasonably recent webbrowser that makes use of
 114   # these. Transfer encoding just eats up bandwidth...
 115
 116   # so all I'm going to do is add a fail safe that if anyone ever encounters
 117   # this, it's going to croak so that debugging is easier
 118   $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/;
 119   my $boundary = '--' . $1;
 120
 121   my $index = 0;
 122   my $line_length;
 123   foreach my $line (split m/\n/, $input) {
 124     $line_length = length $line;
 125
 126     if ($line =~ /^\Q$boundary\E(--)?\r?$/) {
 127       my $last_boundary = $1;
 128       my $data       =  substr $input, $data_start, $index - $data_start;
 129       $data =~ s/\r?\n$//;
 130
 131       if ($previous && !$filename && $transfer_encoding && $transfer_encoding ne 'binary') {
 132         ${ $previous } = Encode::decode($encoding, $data);
 133       } else {
 134         ${ $previous } = $data;
 135       }
 136       $::lxdebug->add_request_params($name, $$previous) if $log;
 137
 138       undef $previous;
 139       undef $filename;
 140
 141       $headers_done   = 0;
 142       $content_type   = "text/plain";
 143       $boundary_found = 1;
 144       $need_cr        = 0;
 145       $encoding       = 'UTF-8';
 146       $transfer_encoding = undef;
 147       last if $last_boundary;
 148       next;
 149     }
 150
 151     next unless $boundary_found;
 152
 153     if (!$headers_done) {
 154       $line =~ s/[\r\n]*$//;
 155
 156       if (!$line) {
 157         $headers_done = 1;
 158         $data_start = $index + $line_length + 1;
 159         next;
 160       }
 161
 162       if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
 163         if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
 164           $filename = $1;
 165           substr $line, $-[0], $+[0] - $-[0], "";
 166         }
 167
 168         if ($line =~ m|name\s*=\s*"(.*?)"|i) {
 169           $name = $1;
 170           substr $line, $-[0], $+[0] - $-[0], "";
 171         }
 172
 173         if ($name) {
 174           # legacy, some old upload routines expect this to be here
 175           $temp_target->{FILENAME} = $filename if defined $filename;
 176
 177           # Name can potentially be both a normal variable or a file upload.
 178           # A file upload can be identified by its "filename" attribute.
 179           # The thing is, if a [+] clause vivifies structure in one of the
 180           # branches it must be done in both, or subsequent "[]" will fail
 181           my $temp_target_slot = _store_value($temp_target, $name);
 182           my $target_slot      = _store_value($target,      $name);
 183
 184           # set the reference for appending of multiline data to the correct one
 185           $previous            = defined $filename ? $target_slot : $temp_target_slot;
 186
 187           # for multiple uploads: save the attachments in a SL/Mailer like structure
 188           if (defined $filename) {
 189             my $target_attachment      = _store_value($target,      "ATTACHMENTS.$name", {});
 190             my $temp_target_attachment = _store_value($temp_target, "ATTACHMENTS.$name", {});
 191
 192             $$target_attachment->{data}          = $previous;
 193             $$temp_target_attachment->{filename} = $filename;
 194
 195             $p_attachment = $$temp_target_attachment;
 196           }
 197         }
 198
 199         next;
 200       }
 201
 202       if ($line =~ m|^content-type\s*:\s*(.*?)[;\$]|i) {
 203         $content_type = $1;
 204         $p_attachment->{content_type} = $1;
 205
 206         if ($content_type =~ /^text/ && $line =~ m|;\s*charset\s*:\s*("?)(.*?)\1$|i) {
 207           $encoding = $2;
 208         }
 209
 210         next;
 211       }
 212
 213       if ($line =~ m|^content-transfer-encoding\s*=\s*(.*?)$|i) {
 214         $transfer_encoding = lc($1);
 215         if ($transfer_encoding  && $transfer_encoding !~ /^[78]bit|binary$/) {
 216           die 'Transfer encodings beyond 7bit/8bit and binary are not implemented.';
 217         }
 218         $p_attachment->{transfer_encoding} = $transfer_encoding;
 219
 220         next;
 221       }
 222
 223       next;
 224     }
 225
 226     next unless $previous;
 227
 228   } continue {
 229     $index += $line_length + 1;
 230   }
 231
 232   $::lxdebug->leave_sub(2);
 233 }
 234
 235 sub _recode_recursively {
 236   $::lxdebug->enter_sub;
 237   my ($iconv, $from, $to) = @_;
 238
 239   if (any { ref $from eq $_ } qw(Form HASH)) {
 240     for my $key (keys %{ $from }) {
 241       if (!ref $from->{$key}) {
 242         # Workaround for a bug: converting $from->{$key} directly
 243         # leads to 'undef'. I don't know why. Converting a copy works,
 244         # though.
 245         $to->{$key} = $iconv->convert("" . $from->{$key}) if defined $from->{$key} && !defined $to->{$key};
 246       } else {
 247         $to->{$key} ||= {} if 'HASH'  eq ref $from->{$key};
 248         $to->{$key} ||= [] if 'ARRAY' eq ref $from->{$key};
 249         _recode_recursively($iconv, $from->{$key}, $to->{$key});
 250       }
 251     }
 252
 253   } elsif (ref $from eq 'ARRAY') {
 254     foreach my $idx (0 .. scalar(@{ $from }) - 1) {
 255       if (!ref $from->[$idx]) {
 256         # Workaround for a bug: converting $from->[$idx] directly
 257         # leads to 'undef'. I don't know why. Converting a copy works,
 258         # though.
 259         $to->[$idx] = $iconv->convert("" . $from->[$idx]) if defined $from->[$idx] && !defined $to->[$idx];
 260       } else {
 261         $to->[$idx] ||= {} if 'HASH'  eq ref $from->[$idx];
 262         $to->[$idx] ||= [] if 'ARRAY' eq ref $from->[$idx];
 263         _recode_recursively($iconv, $from->[$idx], $to->[$idx]);
 264       }
 265     }
 266   }
 267   $main::lxdebug->leave_sub();
 268 }
 269
 270 sub read_cgi_input {
 271   $::lxdebug->enter_sub;
 272
 273   my ($target) = @_;
 274
 275   # yes i know, copying all those values around isn't terribly efficient, but
 276   # the old version of dumping everything into form and then launching a
 277   # tactical recode nuke at the data is still worse.
 278
 279   # this way the data can at least be recoded on the fly as soon as we get to
 280   # know the source encoding and only in the cases where encoding may be hidden
 281   # among the payload we take the hit of copying the request around
 282   my $temp_target = { };
 283
 284   # since both of these can potentially bring their encoding in INPUT_ENCODING
 285   # they get dumped into temp_target
 286   _input_to_hash($temp_target, $ENV{QUERY_STRING}, 1) if $ENV{QUERY_STRING};
 287   _input_to_hash($temp_target, $ARGV[0],           1) if @ARGV && $ARGV[0];
 288
 289   if ($ENV{CONTENT_LENGTH}) {
 290     my $content;
 291     read STDIN, $content, $ENV{CONTENT_LENGTH};
 292     if ($ENV{'CONTENT_TYPE'} && $ENV{'CONTENT_TYPE'} =~ /multipart\/form-data/) {
 293       # multipart formdata can bring it's own encoding, so give it both
 294       # and let it decide on it's own
 295       _parse_multipart_formdata($target, $temp_target, $content, 1);
 296     } else {
 297       # normal encoding must be recoded
 298       _input_to_hash($temp_target, $content, 1);
 299     }
 300   }
 301
 302   my $encoding     = delete $temp_target->{INPUT_ENCODING} || 'UTF-8';
 303
 304   _recode_recursively(SL::Iconv->new($encoding, 'UTF-8'), $temp_target => $target) if keys %$target;
 305
 306   if ($target->{RESTORE_FORM_FROM_SESSION_ID}) {
 307     my %temp_form;
 308     $::auth->restore_form_from_session(delete $target->{RESTORE_FORM_FROM_SESSION_ID}, form => \%temp_form);
 309     _store_value($target, $_, $temp_form{$_}) for keys %temp_form;
 310   }
 311
 312   $::lxdebug->leave_sub;
 313
 314   return $target;
 315 }
 316
 317 sub flatten {
 318   my ($source, $target, $prefix, $in_array) = @_;
 319   $target ||= [];
 320
 321   # There are two edge cases that need attention. First: more than one hash
 322   # inside an array.  Only the first of each nested can have a [+].  Second: if
 323   # an array contains mixed values _store_value will rely on autovivification.
 324   # So any type change must have a [+]
 325   # This closure decides one recursion step AFTER an array has been found if a
 326   # [+] needs to be generated
 327   my $arr_prefix = sub {
 328     return $_[0] ? '[+]' : '[]' if $in_array;
 329     return '';
 330   };
 331
 332   for (ref $source) {
 333     /^HASH$/ && do {
 334       my $first = 1;
 335       for my $key (sort keys %$source) {
 336         flatten($source->{$key} => $target, (defined $prefix ? $prefix . $arr_prefix->($first) . '.' : '') . $key);
 337         $first = 0;
 338       };
 339       next;
 340     };
 341     /^ARRAY$/ && do {
 342       for my $i (0 .. $#$source) {
 343         flatten($source->[$i] => $target, $prefix . $arr_prefix->($i == 0), '1');
 344       }
 345       next;
 346     };
 347     !$_ && do {
 348       die "can't flatten a pure scalar" unless defined $prefix;
 349       push @$target, [ $prefix . $arr_prefix->(0) => $source ];
 350       next;
 351     };
 352     die "unrecognized reference of a data structure $_. cannot serialize refs, globs and code yet. to serialize Form please use the method there";
 353   }
 354
 355   return $target;
 356 }
 357
 358
 359 sub unflatten {
 360   my ($data, $target) = @_;
 361   $target ||= {};
 362
 363   for my $pair (@$data) {
 364     _store_value($target, @$pair) if defined $pair->[0];
 365   }
 366
 367   return $target;
 368 }
 369
 370 1;
 371
 372 __END__
 373
 374 =head1 NAME
 375
 376 SL::Request.pm - request parsing, data serialization, request information
 377
 378 =head1 SYNOPSIS
 379
 380 This module handles unpacking of CGI parameters. It also gives
 381 information about the request, such as whether or not it was done via AJAX,
 382 or the requested content type.
 383
 384   use SL::Request qw(read_cgi_input);
 385
 386   # read cgi input depending on request type, unflatten and recode
 387   read_cgi_input($target_hash_ref);
 388
 389   # $hashref and $new_hashref should be identical
 390   my $new_arrayref = flatten($hashref);
 391   my $new_hashref  = unflatten($new_arrayref);
 392
 393   # Handle AJAX requests differently than normal requests:
 394   if ($::request->is_ajax) {
 395     $controller->render('json-mask', { type => 'json' });
 396   } else {
 397     $controller->render('full-mask');
 398   }
 399
 400 =head1 DESCRIPTION
 401
 402 This module provides information about the request made by the
 403 browser.
 404
 405 It also handles flattening and unflattening of data for request
 406 roundtrip purposes. kivitendo uses the format as described below:
 407
 408 =over 4
 409
 410 =item Hashes
 411
 412 Hash entries will be connected with a dot (C<.>). A simple hash like this
 413
 414   order => {
 415     item     => 2,
 416     customer => 5
 417   }
 418
 419 will be serialized to
 420
 421   [ order.item     => 2 ],
 422   [ order.customer => 5 ],
 423
 424 =item Arrays
 425
 426 Arrays will be marked by empty brackets (C<[]>). A hash like this
 427
 428   selected_id => [ 2, 6, 8, 9 ]
 429
 430 will be flattened to
 431
 432   [ selected_id[] => 2 ],
 433   [ selected_id[] => 6 ],
 434   [ selected_id[] => 8 ],
 435   [ selected_id[] => 9 ],
 436
 437 Since this will produce identical keys, the resulting flattened list can not be
 438 used as a hash. It is however very easy to use this in a template to generate
 439 input:
 440
 441   [% FOREACH id = selected_ids %]
 442     <input type="hidden" name="selected_id[]" value="[% id | html %]">
 443   [% END %]
 444
 445 =item Nested structures
 446
 447 A special version of this are nested hashes in an array, which is very common.
 448 The combined operator (C<[].>) will be used. As a special case, every time a new
 449 array slice is started, the special convention (C<[+].>) will be used. Again this
 450 is because it's easy to write a template with it.
 451
 452 So this
 453
 454   order => {
 455     orderitems => [
 456       {
 457         id   => 1,
 458         part => 15
 459       },
 460       {
 461         id   => 2,
 462         part => 7
 463       },
 464     ]
 465   }
 466
 467 will be
 468
 469   [ order.orderitems[+].id  => 1  ],
 470   [ order.orderitems[].part => 15 ],
 471   [ order.orderitems[+].id  => 2  ],
 472   [ order.orderitems[].part => 7  ],
 473
 474 =item Limitations
 475
 476   The format currently does have certain limitations when compared to other
 477   serialization formats.
 478
 479 =over 4
 480
 481 =item Order
 482
 483 The order of serialized values matters to reconstruct arrays properly. This
 484 should rarely be a problem if you just flatten and dump into a url or a field
 485 of hiddens.
 486
 487 =item Empty Keys
 488
 489 The current implementation of flatten does produce correct serialization of
 490 empty keys, but unflatten is unable to resolve these. Do no use C<''> or
 491 C<undef> as keys. C<0> is fine.
 492
 493 =item Key Escaping
 494
 495 You cannot use the tokens C<[]>, C<[+]> and C<.> in keys. No way around it.
 496
 497 =item Sparse Arrays
 498
 499 It is not possible to serialize something like
 500
 501   sparse_array => do { my $sa = []; $sa[100] = 1; $sa },
 502
 503 This is a feature, as perl doesn't do well with very large arrays.
 504
 505 =item Recursion
 506
 507 There is currently no support nor prevention for flattening a circular structure.
 508
 509 =item Custom Delimiter
 510
 511 No support for other delimiters, sorry.
 512
 513 =item Other References
 514
 515 No support for globs, scalar refs, code refs, filehandles and the like. These will die.
 516
 517 =back
 518
 519 =back
 520
 521 =head1 FUNCTIONS
 522
 523 =over 4
 524
 525 =item C<flatten HASHREF [ ARRAYREF ]>
 526
 527 This function will flatten the provided hash ref into the provided array ref.
 528 The array ref may be non empty, but will be changed in this case.
 529
 530 The return value is the flattened array ref.
 531
 532 =item C<unflatten ARRAYREF [ HASHREF ]>
 533
 534 This function will parse the array ref, and will store the contents into the hash ref. The hash ref may be non empty, in this case any new keys will override the old ones only on leafs with same type. Type changes on a node will die.
 535
 536 =item C<is_ajax>
 537
 538 Returns trueish if the request is an XML HTTP request, also known as
 539 an 'AJAX' request.
 540
 541 =item C<type>
 542
 543 Returns the requested content type (either C<html>, C<js> or C<json>).
 544
 545 =item C<layout>
 546
 547 Set and retrieve the layout object for the current request. Must be an instance
 548 of L<SL::Layout::Base>. Defaults to an instance of L<SL::Layout::None>.
 549
 550 For more information about layouts, see L<SL::Layout::Dispatcher>.
 551
 552 =item C<cache $topic[, $default ]>
 553
 554 Caches an item for the duration of the request. C<$topic> must be an
 555 index name referring to the thing to cache. It is used for retrieving
 556 it later on. If C<$topic> doesn't start with C<::> then the caller's
 557 package name is prepended to the topic. For example, if the a from
 558 package C<SL::StuffedStuff> calls with topic = C<get_stuff> then the
 559 actual key will be C<::SL::StuffedStuff::get_stuff>.
 560
 561 If no item exists in the cache for C<$topic> then it is created and
 562 its initial value is set to C<$default>. If C<$default> is not given
 563 (undefined) then a new, empty hash reference is created.
 564
 565 Returns the cached item.
 566
 567 =back
 568
 569 =head1 SPECIAL FUNCTIONS
 570
 571 =head2 C<_store_value()>
 572
 573 Parses a complex var name, and stores it in the form.
 574
 575 Syntax:
 576   _store_value($target, $key, $value);
 577
 578 Keys must start with a string, and can contain various tokens.
 579 Supported key structures are:
 580
 581 1. simple access
 582   Simple key strings work as expected
 583
 584   id => $form->{id}
 585
 586 2. hash access.
 587   Separating two keys by a dot (.) will result in a hash lookup for the inner value
 588   This is similar to the behaviour of java and templating mechanisms.
 589
 590   filter.description => $form->{filter}->{description}
 591
 592 3. array+hashref access
 593
 594   Adding brackets ([]) before the dot will cause the next hash to be put into an array.
 595   Using [+] instead of [] will force a new array index. This is useful for recurring
 596   data structures like part lists. Put a [+] into the first varname, and use [] on the
 597   following ones.
 598
 599   Repeating these names in your template:
 600
 601     invoice.items[+].id
 602     invoice.items[].parts_id
 603
 604   will result in:
 605
 606     $form->{invoice}->{items}->[
 607       {
 608         id       => ...
 609         parts_id => ...
 610       },
 611       {
 612         id       => ...
 613         parts_id => ...
 614       }
 615       ...
 616     ]
 617
 618 4. arrays
 619
 620   Using brackets at the end of a name will result in the creation of a pure array.
 621   Note that you mustn't use [+], which is reserved for array+hash access and will
 622   result in undefined behaviour in array context.
 623
 624   filter.status[]  => $form->{status}->[ val1, val2, ... ]
 625
 626 =cut