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