Verknüfpte Belege: Keine Verknüpfungen zu Angebot von Angebot oder Auftrag.
[kivitendo-erp.git] / 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