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