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