File Coverage

blib/lib/MVC/Neaf/Request.pm
Criterion Covered Total %
statement 414 425 97.4
branch 151 202 74.7
condition 83 142 58.4
subroutine 95 97 97.9
pod 63 63 100.0
total 806 929 86.7


line stmt bran cond sub pod time code
1             package MVC::Neaf::Request;
2              
3 94     94   731445 use strict;
  94         346  
  94         2999  
4 94     94   582 use warnings;
  94         245  
  94         4777  
5              
6             our $VERSION = '0.2901';
7              
8             =head1 NAME
9              
10             MVC::Neaf::Request - Request class for Not Even A Framework
11              
12             =head1 DESCRIPTION
13              
14             This is what your L application is going to get as its ONLY input.
15              
16             Here's a brief overview of what a Neaf request returns:
17              
18             # How the application was configured:
19             MVC::Neaf->route( "/matching/route" => sub { my $req = shift; ... },
20             path_info_regex => '.*' );
21              
22             # What was requested:
23             http(s)://server.name:1337/mathing/route/some/more/slashes?foo=1&bar=2
24              
25             # What is being returned:
26             $req->http_version = HTTP/1.0 or HTTP/1.1
27             $req->scheme = http or https
28             $req->method = GET
29             $req->hostname = server.name
30             $req->port = 1337
31             $req->path = /mathing/route/some/more/slashes
32             $req->prefix = /mathing/route
33             $req->postfix = some/more/slashes
34              
35             # params and cookies require a regex
36             $req->param( foo => '\d+' ) = 1
37              
38             =head1 REQUEST METHODS
39              
40             The actual Request object the application gets is going to be
41             a subclass of this.
42             Thus it is expected to have the following methods.
43              
44             =cut
45              
46 94     94   3205 use Carp;
  94         1671  
  94         5810  
47 94     94   5103 use URI::Escape;
  94         13976  
  94         5110  
48 94     94   5437 use Encode;
  94         141275  
  94         7347  
49 94     94   5050 use HTTP::Headers::Fast;
  94         44147  
  94         2524  
50 94     94   52471 use Time::HiRes ();
  94         140260  
  94         2500  
51 94     94   52264 use Sys::Hostname ();
  94         100244  
  94         2717  
52 94     94   628 use Digest::MD5 qw(md5);
  94         219  
  94         5623  
53              
54 94     94   6759 use MVC::Neaf::Util qw( JSON http_date run_all_nodie canonize_path encode_b64 );
  94         208  
  94         5886  
55 94     94   40269 use MVC::Neaf::Upload;
  94         256  
  94         2984  
56 94     94   40205 use MVC::Neaf::Exception;
  94         274  
  94         2824  
57 94     94   40320 use MVC::Neaf::Route::PreRoute;
  94         254  
  94         598824  
58              
59             our %allow_helper;
60              
61             =head2 new()
62              
63             MVC::Neaf::Request->new( %arguments )
64              
65             The application is not supposed to make its own requests,
66             so this constructor is really for testing purposes only.
67              
68             For now, just swallows whatever is given to it.
69             Restrictions MAY BE added in the future though.
70              
71             =cut
72              
73             sub new {
74 172     172 1 2742 my ($class, %args) = @_;
75              
76             # TODO 0.30 restrict params
77 172         629 return bless \%args, $class;
78             };
79              
80             # TODO 0.90 A lot of copypasted methods down here.
81             # Should we join them all? Maybe...
82              
83             =head2 client_ip()
84              
85             Returns the IP of the client.
86             If C header is set, returns that instead.
87              
88             =cut
89              
90             sub client_ip {
91 1     1 1 2112 my $self = shift;
92              
93 1   33     6 return $self->{client_ip} ||= do {
94 1         8 my @fwd = $self->header_in( 'X-Forwarded-For', '.*' );
95 1 50 33     22 @fwd == 1 && $fwd[0] || $self->do_get_client_ip || "127.0.0.1";
      33        
96             };
97             };
98              
99             =head2 http_version()
100              
101             Returns version number of C protocol.
102              
103             =cut
104              
105             sub http_version {
106 2     2 1 6 my $self = shift;
107              
108 2 50       11 if (!exists $self->{http_version}) {
109 2         29 $self->{http_version} = $self->do_get_http_version;
110             };
111              
112 1         5 return $self->{http_version};
113             };
114              
115             =head2 scheme()
116              
117             Returns C or C, depending on how the request was done.
118              
119             =cut
120              
121             sub scheme {
122 13     13 1 66 my $self = shift;
123              
124 13 100       51 if (!exists $self->{scheme}) {
125 9   100     34 $self->{scheme} = $self->do_get_scheme || 'http';
126             };
127              
128 11         120 return $self->{scheme};
129             };
130              
131             =head2 secure()
132              
133             Returns true if C is used, false otherwise.
134              
135             =cut
136              
137             # TODO 0.90 secure should be a flag, scheme should depend on it
138             sub secure {
139 3     3 1 24 my $self = shift;
140 3         12 return $self->scheme eq 'https';
141             };
142              
143             =head2 method()
144              
145             Return the C method being used.
146             C is the default value if cannot determine
147             (useful for command-line debugging).
148              
149             =cut
150              
151             sub method {
152 347     347 1 681 my $self = shift;
153 347   50     1922 return $self->{method} ||= $self->do_get_method || "GET";
      100        
154             };
155              
156             =head2 is_post()
157              
158             Alias for C<$self-Emethod eq 'POST'>.
159             May be useful in form submission, as in
160              
161             $form = $request->form( $validator );
162             if ($request->is_post and $form->is_valid) {
163             # save & redirect
164             };
165             # show form again
166              
167             =cut
168              
169             sub is_post {
170 1     1 1 3 my $self = shift;
171 1         3 return $self->method eq 'POST';
172             };
173              
174             =head2 hostname()
175              
176             Returns the hostname that was requested, or C if cannot detect.
177              
178             =cut
179              
180             sub hostname {
181 4     4 1 8 my $self = shift;
182              
183 4   50     19 return $self->{hostname} ||= $self->do_get_hostname || "localhost";
      66        
184             # TODO 0.90 what if http://0/?
185             };
186              
187             =head2 port()
188              
189             Returns the port number.
190              
191             =cut
192              
193             sub port {
194 5     5 1 15 my $self = shift;
195              
196 5   100     27 return $self->{port} ||= $self->do_get_port;
197             };
198              
199             =head2 path()
200              
201             Returns the path part of the URI. Path is guaranteed to start with a slash.
202              
203             =cut
204              
205             sub path {
206 184     184 1 402 my $self = shift;
207              
208 184   66     996 return $self->{path} ||= $self->do_get_path;
209             };
210              
211             =head2 route()
212              
213             A L object that this request is being dispatched to.
214              
215             If request is not inside an application, returns a L
216             instead.
217              
218             =cut
219              
220             sub route {
221 830     830 1 1682 my $self = shift;
222 830   66     3452 return $self->{route} ||= MVC::Neaf::Route::PreRoute->new(
223             method => 'GET',
224             );
225             };
226              
227             =head2 set_path()
228              
229             $req->set_path( $new_path )
230              
231             Set path() to new value. This may be useful in C hook.
232              
233             Path will be canonized.
234              
235             If no argument given, or it is C, resets path() value to
236             underlying driver's C.
237              
238             Returns self.
239              
240             =cut
241              
242             sub set_path {
243 2     2 1 9 my ($self, $new_path) = @_;
244              
245 2 50       8 $self->{path} = defined $new_path
246             ? canonize_path( $new_path, 1 )
247             : $self->do_get_path;
248              
249 2         4 $self;
250             };
251              
252             =head2 prefix()
253              
254             The part of the request that matched the route to the
255             application being executed.
256              
257             Guaranteed to start with slash.
258             Unless C was called, it is a prefix of C.
259              
260             Not available before routing was applied to request.
261              
262             =cut
263              
264             sub prefix {
265 5     5 1 19 my $self = shift;
266              
267             # TODO kill in 0.30
268             carp "NEAF: prefix() call before routing was applied is DEPRECATED: "
269 5 50 33     38 unless $self->{route} && $self->{route}->path =~ m,^(?:/|$),;
270              
271 5   66     27 return $self->{prefix} ||= $self->path;
272             };
273              
274             =head2 get_url_base()
275              
276             Get scheme, server, and port of the application.
277              
278             B<[EXPERIMENTAL]> Name and meaning subject to change.
279              
280             =head2 get_url_rel( ... )
281              
282             =over
283              
284             =item * C<$req-Eget_url_rel( %override )>
285              
286             =back
287              
288             Produce a relative link to the page being served,
289             possibly overriding some parameters.
290              
291             Parameter order is NOT preserved. If parameter is empty or C,
292             it is skipped.
293              
294             B<[CAUTION]> Multiple values are ignored, this MAY change in the future.
295              
296             B<[CAUTION]> For a POST request, normal parameters are used instead of URL
297             parameters (see C). This MAY change in the future.
298              
299             B<[EXPERIMENTAL]> Name and meaning subject to change.
300              
301             =head2 get_url_full( ... )
302              
303             =over
304              
305             =item * C<$req-Eget_url_full( %override )>
306              
307             =back
308              
309             Same as above, but prefixed with schema, server name, and port.
310              
311             B<[EXPERIMENTAL]> Name and meaning subject to change.
312              
313             =cut
314              
315             sub get_url_rel {
316 3     3 1 57 my ($self, %override) = @_;
317              
318 3         5 my %h = (%{ $self->_all_params }, %override );
  3         10  
319              
320             return $self->path . '?' . join '&'
321 4         42 , map { uri_escape_utf8($_) . "=" .uri_escape_utf8($h{$_}) }
322 3 100       8 grep { defined $h{$_} && length $h{$_} }
  7         29  
323             sort keys %h;
324             };
325              
326             my %port_scheme = (
327             http => 80,
328             https => 443,
329             );
330              
331             sub get_url_base {
332 3     3 1 5 my $self = shift;
333              
334             # skip well-known ports
335 3 100 50     8 my $port = ($self->port == ($port_scheme{ $self->scheme } || 0))
336             ? ''
337             : ':'.$self->port;
338              
339 3         7 return join "", $self->scheme, "://", $self->hostname, $port;
340             };
341              
342             sub get_url_full {
343 3     3 1 18 my $self = shift;
344 3         9 return $self->get_url_base . $self->get_url_rel(@_);
345             };
346              
347             =head2 postfix()
348              
349             Returns the part of URI path beyond what matched the application's path.
350              
351             Contrary to the
352             L,
353             the leading slash is REMOVED.
354              
355             The validation regex for this value MUST be specified during application
356             setup as C. See C in L.
357              
358             B<[EXPERIMENTAL]> This part of API is undergoing changes.
359              
360             =cut
361              
362             sub postfix {
363 18     18 1 1315 my ($self) = @_;
364              
365 18         80 return $self->{postfix};
366             };
367              
368             =head2 splat()
369              
370             Return a list of matched capture groups found in path_info_regex, if any.
371              
372             =cut
373              
374             sub splat {
375 1     1 1 3 my $self = shift;
376              
377 1 50       3 return @{ $self->{path_info_split} || [] };
  1         10  
378             };
379              
380             # This is somewhat ugly.
381             # When a route is matched, we'll store it
382             # and _also_ the leftovers of regex splitting that happens around that moment
383             sub _import_route {
384 293     293   775 my ($self, $route, $path, $path_info, $tail) = @_;
385              
386 293         583 $self->{route} = $route;
387 293 100       805 if (defined $path) {
388 136         532 $self->{prefix} = $path;
389 136         367 $self->{postfix} = $path_info;
390 136         405 $self->{path_info_split} = $tail;
391             };
392              
393 293         625 return $self;
394             };
395              
396             =head2 set_path_info( ... )
397              
398             =over
399              
400             =item * C<$req-Eset_path_info( $path_info )>
401              
402             =back
403              
404             Sets path_info to new value.
405              
406             Also updates path() value so that path = script_name + path_info
407             still holds.
408              
409             Returns self.
410              
411             =cut
412              
413             sub set_path_info {
414 2     2 1 6 my ($self, $path_info) = @_;
415              
416 2 100       7 $path_info = '' unless defined $path_info;
417             # CANONIZE
418 2         4 $path_info =~ s#^/+##;
419              
420 2         5 $self->{postfix} = $path_info;
421             $self->{path} = $self->script_name
422 2 100       5 .(length $self->{postfix} ? "/$self->{postfix}" : '');
423              
424 2         5 return $self;
425             };
426              
427             =head2 param( ... )
428              
429             =over
430              
431             =item * $req->param( $name, $regex )
432              
433             =item * $req->param( $name, $regex, $default )
434              
435             =back
436              
437             Return parameter, if it passes regex check, default value or C otherwise.
438              
439             The regular expression is applied to the WHOLE string,
440             from beginning to end, not just the middle.
441             Use '.*' if you really trust the data.
442              
443             Dies if regular expression didn't match and the route has the C flag.
444              
445             B<[EXPERIMENTAL]> If C hash was given during route definition,
446             C<$regex> MAY be omitted for params that were listed there.
447             This feature is not stable yet, though. Use with care.
448              
449             If method other than GET/HEAD is being used, whatever is in the
450             address line after ? is IGNORED.
451             Use L (see below) if you intend to mix GET/POST parameters.
452              
453             B<[NOTE]> C ALWAYS returns a single value, even in list context.
454             Use C (see below) if you really want a list.
455              
456             B<[NOTE]> C has I with getting parameter list from request.
457             Instead, use form with wildcards:
458              
459             neaf form => "my_form" => [ [ 'guest\d+' => '.*'], [ 'arrival\d+' => '.*' ] ],
460             engine => 'Wildcard';
461              
462             # later in controller
463             my $guests = $req->form("my_form");
464             $guests->fields; # has guest1 & arrival1, guest2 & arrival2 etc
465             $guests->error; # hash with values that didn't match regex
466              
467             See L.
468              
469             =cut
470              
471             sub param {
472 43     43 1 377 my ($self, $name, $regex, $default) = @_;
473              
474 43   100     150 $regex ||= $self->{route}{param_regex}{$name};
475              
476 43 100       130 $self->_croak( "NEAF: param(): a validation regex is REQUIRED" )
477             unless defined $regex;
478              
479             # Some write-through caching
480 41         181 my $value = $self->_all_params->{ $name };
481              
482 41 100       190 return $default if !defined $value;
483 26 100       633 return $value if $value =~ /^(?:$regex)$/s;
484              
485 5 100 100     36 if (length $value && $self->route->strict) {
486 1         11 die 422; # TODO 0.30 configurable die message
487             };
488 4         17 return $default;
489             };
490              
491             =head2 url_param( ... )
492              
493             =over
494              
495             =item * C<$req-Eurl_param( name =E qr/regex/ )>
496              
497             =back
498              
499             If method is GET or HEAD, identical to C.
500              
501             Otherwise would return the parameter from query string,
502             AS IF it was a GET request.
503              
504             Dies if regular expression didn't match and the route has the C flag.
505              
506             Multiple values are deliberately ignored.
507              
508             See L.
509              
510             =cut
511              
512             our %query_allowed = ( GET => 1, HEAD => 1);
513             sub url_param {
514 2     2 1 23 my ($self, $name, $regex, $default) = @_;
515              
516 2 100       11 if ($query_allowed{ $self->method }) {
517 1         4 return $self->param( $name, $regex, $default );
518             };
519              
520             # HACK here - some lazy caching + parsing string by hand
521 1   33     19 $self->{url_param_hash} ||= do {
522 1         2 my %hash;
523              
524 1   50     8 foreach (split /[&;]/, $self->{query_string} || '' ) {
525 1 50       9 /^(.*?)(?:=(.*))?$/ or next;
526 1         6 $hash{$1} = $2;
527             };
528              
529             # causes error w/o + (context issues?)
530             # do decoding AFTER uniq'ing params (plus it was simpler to write)
531 1         4 +{ map { decode_utf8(uri_unescape($_)) } %hash };
  2         25  
532             };
533 1         19 my $value = $self->{url_param_hash}{$name};
534              
535             # this is copypaste from param(), do something (or don't)
536 1 50       4 return $default if !defined $value;
537 1 50       47 return $value if $value =~ /^(?:$regex)$/s;
538              
539 0 0 0     0 if (length $value && $self->route->strict) {
540 0         0 die 422; # TODO 0.30 configurable die message
541             };
542 0         0 return $default;
543             };
544              
545             =head2 multi_param( ... )
546              
547             =over
548              
549             =item * C<$req-Emulti_param( name =E qr/regex/ )>
550              
551             =back
552              
553             Get a multiple value GET/POST parameter as a C<@list>.
554             The name generally follows that of newer L (4.08+).
555              
556             ALL values must match the regex, or an empty list is returned.
557             Dies if strict mode if enabled for route and there is a mismatch.
558              
559             B<[EXPERIMENTAL]> If C hash was given during route definition,
560             C<$regex> MAY be omitted for params that were listed there.
561             This feature is not stable yet, though. Use with care.
562              
563             B<[EXPERIMENTAL]> This method's behavior MAY change in the future.
564             Please be careful when upgrading.
565              
566             =cut
567              
568             # TODO 0.90 merge multi_param, param, and _all_params
569             # backend mechanism.
570              
571             sub multi_param {
572 9     9 1 47 my ($self, $name, $regex) = @_;
573              
574 9   66     37 $regex ||= $self->{route}{param_regex}{$name};
575 9 50       22 $self->_croak( "validation regex is REQUIRED" )
576             unless defined $regex;
577              
578             my $ret = $self->{multi_param}{$name} ||= [
579 9   100     54 map { decode_utf8($_) } $self->do_get_param_as_array( $name ),
  9         849  
580             ];
581              
582             # ANY mismatch = no go. Replace with simple grep if want filter EVER.
583 9 100       285 if (grep { !/^(?:$regex)$/s } @$ret) {
  13         176  
584 3 50       13 die 422 if $self->route->strict;
585 3         26 return ();
586             } else {
587 6         47 return @$ret;
588             };
589             };
590              
591             =head2 set_param( ... )
592              
593             =over
594              
595             =item * C<$req-Eset_param( name =E $value )>
596              
597             =back
598              
599             Override form parameter. Returns self.
600              
601             =cut
602              
603             sub set_param {
604 1     1 1 4 my ($self, $name, $value) = @_;
605              
606 1         2 $self->{cached_params}{$name} = $value;
607 1         3 return $self;
608             };
609              
610             =head2 form( ... )
611              
612             =over
613              
614             =item * C<$req-Eform( $validator )>
615              
616             =back
617              
618             Apply validator to raw params and return whatever it returns.
619              
620             A validator MUST be an object with C method, or a coderef,
621             or a symbolic name registered earlier via C.
622              
623             Neaf's own validators, C and C,
624             will return a C object with the following methods:
625              
626             =over
627              
628             =item * is_valid - tells whether data passed validation
629              
630             =item * error - hash of errors, can also be modified if needed:
631              
632             $result->error( myfield => "Correct, but not found in database" );
633              
634             =item * data - hash of valid, cleaned data
635              
636             =item * raw - hash of data entered initially, may be useful to display
637             input form again.
638              
639             =back
640              
641             You are encouraged to use this return format from your own validation class
642             or propose improvements.
643              
644             =cut
645              
646             sub form {
647 7     7 1 113 my ($self, $validator) = @_;
648              
649 7 100       25 if (!ref $validator) {
650 4   33     23 $validator = $self->{route}->get_form( $validator )
651             || $self->_croak("Unknown form name $validator");
652             };
653              
654 6 50       60 my $result = (ref $validator eq 'CODE')
655             ? $validator->( $self->_all_params )
656             : $validator->validate( $self->_all_params );
657              
658 6         17 return $result;
659             };
660              
661             =head2 get_form_as_list( ... )
662              
663             =over
664              
665             =item * C<$req-Eget_form_as_list( qr/.../, qw(name1 name2 ...) )>
666              
667             =back
668              
669             =head2 get_form_as_list( ... )
670              
671             =over
672              
673             =item * C<$req-Eget_form_as_list( [ qr/.../, "default" ], qw(name1 name2 ...) )>
674              
675             =back
676              
677             Return a group of uniform parameters as a list, in that order.
678             Values that fail validation are returned as C, unless default given.
679              
680             B<[EXPERIMENTAL]> The name MAY be changed in the future.
681              
682             =cut
683              
684             sub get_form_as_list {
685 2     2 1 12 my ($self, $spec, @list) = @_;
686              
687 2 50       7 $self->_croak( "Meaningless call in scalar context" )
688             unless wantarray;
689              
690 2 100       11 $spec = [ $spec, undef ]
691             unless ref $spec eq 'ARRAY';
692              
693             # Call the same validation over for each parameter
694 2         6 return map { $self->param( $_, @$spec ); } @list;
  6         16  
695             };
696              
697             sub _all_params {
698 51     51   106 my $self = shift;
699              
700 51   66     208 return $self->{cached_params} ||= do {
701 36         132 my $raw = $self->do_get_params;
702              
703             $_ = decode_utf8($_)
704 36         541 for (values %$raw);
705              
706 36         501 $raw;
707             };
708             };
709              
710             =head2 body()
711              
712             See L below.
713              
714             =head2 body_text()
715              
716             Returns request body for PUT/POST requests as unicode text.
717              
718             B Encodings other than UTF-8 are not supported as of yet.
719              
720             =head2 body_json()
721              
722             Get decoded request body in JSON format.
723             In case of errors, error 422 is thrown.
724              
725             =head2 body_raw()
726              
727             Returns request body for PUT/POST requests as binary data.
728             Decoding and validation is left up to the user.
729              
730             =cut
731              
732             sub body_raw {
733 6     6 1 18 my $self = shift;
734              
735             carp ("MVC::Neaf: using body() is discouraged for method ".$self->method)
736 6 50       22 if ($query_allowed{$self->method});
737              
738             $self->{body} = $self->do_get_body
739 6 50       50 unless exists $self->{body};
740              
741 6         2046 return $self->{body};
742             };
743              
744             *body = *body = \&body_raw;
745              
746             _helper_fallback( body_text => sub {
747             my $self = shift;
748              
749             # TODO adhere to charset= in content_type
750             return decode_utf8( $self->body_raw );
751             });
752              
753             my $codec = JSON->new->utf8->allow_nonref;
754             _helper_fallback( body_json => sub {
755             my ($self, $validator) = @_;
756              
757             # TODO add validator support - if fails, also 422
758             # TODO but note validator is likely to be path-specific, not call-specific
759             my $data;
760             eval {
761             # Content-Type must be application/json or empty
762             $self->content_type =~ /^(application\/json\b|$)/
763             or die "Unexpected content type for body_json: ".$self->content_type;
764             $data = $codec->decode( $self->body );
765             1;
766             } || do {
767             # TODO do we need to log error here?
768             $@ =~ s/at \S+ line \d+\.?\n?$//;
769             $self->log_message( warning => "Failed to read JSON from request via body_json(): ".$@);
770             die 422;
771             };
772              
773             return $data;
774             } );
775              
776             =head2 upload_utf8( ... )
777              
778             =head2 upload_raw( ... )
779              
780             =over
781              
782             =item * C<$req-Eupload_utf8( "name" )>
783              
784             Returns an L object corresponding to an uploaded file,
785             if such uploaded file is present.
786              
787             All data read from such upload will be converted to unicode,
788             raising an exception if decoding ever fails.
789              
790             An upload object has at least C and C methods to work with
791             data:
792              
793             my $upload = $req->upload("user_file");
794             if ($upload) {
795             my $untrusted_filename = $upload->filename;
796             my $fd = $upload->handle;
797             while (<$fd>) {
798             ...
799             };
800             }
801              
802             or just
803              
804             if ($upload) {
805             while ($upload->content =~ /(...)/g) {
806             do_something($1);
807             };
808             };
809              
810             =item * C<$req-Eupload_raw( "name" )>
811              
812             Like above, but no decoding whatsoever is performed.
813              
814             =back
815              
816             =cut
817              
818             sub upload_utf8 {
819 0     0 1 0 my ($self, $name) = @_;
820 0         0 return $self->_upload( id => $name, utf8 => 1 );
821             };
822              
823             sub upload_raw {
824 1     1 1 14 my ($self, $name) = @_;
825 1         6 return $self->_upload( id => $name, utf8 => 0 );
826             };
827              
828             # TODO 0.30 do something about upload's content type
829             # TODO 0.30 and btw, restrict content types!
830             sub _upload {
831 1     1   5 my ($self, %args) = @_;
832              
833             my $id = $args{id}
834 1 50       6 or $self->_croak( "upload name is required for upload" );
835             # caching undef as well, so exists()
836 1 50       6 if (!exists $self->{uploads}{$id}) {
837 1         5 my $raw = $self->do_get_upload( $id );
838 1 50       5 $self->{uploads}{$id} = (ref $raw eq 'HASH')
839             ? MVC::Neaf::Upload->new( %$raw, %args )
840             : undef;
841             };
842              
843 1         7 return $self->{uploads}{$id};
844             };
845              
846             =head2 get_cookie( ... )
847              
848             =over
849              
850             =item * C<$req-Eget_cookie( "name" =E qr/regex/ [, "default" ] )>
851              
852             =back
853              
854             Fetch client cookie.
855             The cookie MUST be sanitized by regular expression.
856              
857             The regular expression is applied to the WHOLE string,
858             from beginning to end, not just the middle.
859             Use '.*' if you really need none.
860              
861             Dies if regular expression didn't match and the route has the C flag.
862              
863             =cut
864              
865             sub get_cookie {
866 31     31 1 114 my ($self, $name, $regex, $default) = @_;
867              
868 31 100       95 $default = '' unless defined $default;
869 31 50       70 $self->_croak( "validation regex is REQUIRED")
870             unless defined $regex;
871              
872 31   66     130 $self->{neaf_cookie_in} ||= do {
873 23         47 my %hash;
874 23         151 foreach ($self->header_in('cookie', qr/.*/)) {
875 15         128 while (/(\S+?)=([^\s;]*);?/g) {
876 21         261 $hash{$1} = decode_utf8(uri_unescape($2));
877             };
878             };
879 23         498 \%hash;
880             };
881 31         73 my $value = $self->{neaf_cookie_in}{ $name };
882 31 100       93 return $default unless defined $value;
883              
884 21 100       547 return $value if $value =~ /^$regex$/;
885              
886 4 50 33     22 if (length $value && $self->route->strict) {
887 4         38 die 422; # TODO 0.30 configurable die message
888             };
889 0         0 return $default;
890             };
891              
892             =head2 set_cookie( ... )
893              
894             =over
895              
896             =item * C<$req-Eset_cookie( name =E "value", %options )>
897              
898             =back
899              
900             Set HTTP cookie. C<%options> may include:
901              
902             =over
903              
904             =item * C - regular expression to check outgoing value
905              
906             =item * C - time to live in seconds.
907             0 means no C.
908             Use negative C and empty value to delete cookie.
909              
910             =item * C - UNIX time stamp when the cookie expires
911             (overridden by C).
912              
913             =item * C - B<[DEPRECATED]> - use 'expire' instead (without trailing "s")
914              
915             =item * C
916              
917             =item * C
918              
919             =item * C - flag
920              
921             =item * C - flag
922              
923             =back
924              
925             Returns self.
926              
927             =cut
928              
929             sub set_cookie {
930 9     9 1 47 my ($self, $name, $cook, %opt) = @_;
931              
932 9 50 33     35 defined $opt{regex} and $cook !~ /^$opt{regex}$/
933             and $self->_croak( "output value doesn't match regex" );
934 9 50       35 if (exists $opt{expires}) {
935             # TODO 0.30 kill it and croak
936 0         0 carp( "NEAF set_cookie(): 'expires' parameter DEPRECATED, use 'expire' instead" );
937 0         0 $opt{expire} = delete $opt{expires};
938             };
939              
940             # Zero ttl is ok and means "no ttl at all".
941 9 100       27 if ($opt{ttl}) {
942 1         3 $opt{expire} = time + $opt{ttl};
943             };
944              
945             $self->{response}{cookie}{ $name } = [
946             $cook, $opt{regex},
947             $opt{domain}, $opt{path}, $opt{expire}, $opt{secure}, $opt{httponly}
948 9         46 ];
949              
950             # TODO 0.90 also set cookie_in for great consistency, but don't
951             # break reading cookies from backend by cache vivification!!!
952 9         26 return $self;
953             };
954              
955             =head2 delete_cookie( ... )
956              
957             =over
958              
959             =item * C<$req-Edelete_cookie( "name" )>
960              
961             =back
962              
963             Remove cookie by setting value to an empty string,
964             and expiration in the past.
965             B<[NOTE]> It is up to the user agent to actually remove cookie.
966              
967             Returns self.
968              
969             =cut
970              
971             sub delete_cookie {
972 1     1 1 4 my ($self, $name) = @_;
973 1         3 return $self->set_cookie( $name => '', ttl => -100000 );
974             };
975              
976             # Set-Cookie: SSID=Ap4P….GTEq; Domain=foo.com; Path=/;
977             # Expires=Wed, 13 Jan 2021 22:23:01 GMT; Secure; HttpOnly
978              
979             =head2 format_cookies
980              
981             Converts stored cookies into an arrayref of scalars
982             ready to be put into Set-Cookie header.
983              
984             =cut
985              
986             sub format_cookies {
987 160     160 1 9266 my $self = shift;
988              
989 160   100     888 my $cookies = $self->{response}{cookie} || {};
990              
991 160         403 my @out;
992 160         614 foreach my $name (keys %$cookies) {
993             my ($cook, $regex, $domain, $path, $expire, $secure, $httponly)
994 9         18 = @{ $cookies->{$name} };
  9         31  
995 9 50       28 next unless defined $cook; # TODO 0.90 erase cookie if undef?
996              
997 9 50       29 $path = "/" unless defined $path;
998 9 100       39 defined $expire and $expire = http_date( $expire );
999 9 50       52 my $bake = join "; ", ("$name=".uri_escape_utf8($cook))
    100          
    50          
    50          
1000             , defined $domain ? "Domain=$domain" : ()
1001             , "Path=$path"
1002             , defined $expire ? "Expires=$expire" : ()
1003             , $secure ? "Secure" : ()
1004             , $httponly ? "HttpOnly" : ();
1005 9         412 push @out, $bake;
1006             };
1007 160         860 return \@out;
1008             };
1009              
1010             =head2 error( ... )
1011              
1012             =over
1013              
1014             =item * C<$req-Eerror( status )>
1015              
1016             =back
1017              
1018             Report error to the CORE.
1019              
1020             This throws an C object.
1021              
1022             If you're planning calling C<$req-Eerror> within C block,
1023             consider using C function to let it propagate:
1024              
1025             use MVC::Neaf::Exception qw(neaf_err);
1026              
1027             eval {
1028             $req->error(422)
1029             if ($foo);
1030             $req->redirect( "http://google.com" )
1031             if ($bar);
1032             };
1033             if ($@) {
1034             neaf_err($@);
1035             # The rest of the catch block
1036             };
1037              
1038             =cut
1039              
1040             sub error {
1041 1     1 1 423 my $self = shift;
1042 1         5 die MVC::Neaf::Exception->new(@_);
1043             };
1044              
1045             =head2 redirect( ... )
1046              
1047             =over
1048              
1049             =item * C<$req-Eredirect( $location )>
1050              
1051             =back
1052              
1053             Redirect to a new location.
1054              
1055             This throws an MVC::Neaf::Exception object.
1056             See C discussion above.
1057              
1058             =cut
1059              
1060             sub redirect {
1061 2     2 1 16 my ($self, $location) = @_;
1062              
1063 2         24 die MVC::Neaf::Exception->new(
1064             -status => 302,
1065             -location => $location,
1066             -content => 'See '.$location,
1067             -type => 'text/plain',
1068             );
1069             };
1070              
1071             =head2 header_in( ... )
1072              
1073             =over
1074              
1075             =item * C - return headers as-is
1076              
1077             =item * C<$req-Eheader_in( "header_name", qr/.../ )>
1078              
1079             =back
1080              
1081             Fetch HTTP header sent by client.
1082             Header names are canonized,
1083             so C, C and C are all the same.
1084              
1085             Without argument, returns a L object.
1086              
1087             With a name, returns all values for that header in list context,
1088             or ", " - joined value as one scalar in scalar context.
1089             An empty string is returned if no such header is present.
1090              
1091             If regex fails to match I of the header values, error 422 is thrown.
1092              
1093             This call still works without regex, but such behavior is deprecated.
1094              
1095             =cut
1096              
1097             sub header_in {
1098 43     43 1 891 my ($self, $name, $regex) = @_;
1099              
1100 43   66     236 $self->{header_in} ||= $self->do_get_header_in;
1101 43 100       2634 return $self->{header_in} unless defined $name;
1102              
1103 40         95 $name = lc $name;
1104 40         121 $name =~ s/-/_/g;
1105 40         132 my @list = $self->{header_in}->header( $name );
1106              
1107             # TODO 0.30 deprecate w/o regex
1108 40 100       1672 if ($regex) {
1109 37 100 66     311 $regex = qr/^$regex$/
1110             unless ref $regex and ref $regex eq 'Regexp';
1111             $_ =~ $regex or die 422 # TODO 0.30 configurable
1112 37   100     317 for @list;
1113             };
1114              
1115 38 100       208 return wantarray ? @list : join ', ', @list;
1116             };
1117              
1118             =head2 referer
1119              
1120             Get/set HTTP referrer - i.e. where the request pretends to come from.
1121              
1122             B<[NOTE]> Avoid using this for anything serious/secure - too easy to forge.
1123              
1124             =cut
1125              
1126             sub referer {
1127 2     2 1 4 my $self = shift;
1128 2 50       6 if (@_) {
1129             $self->{referer} = shift
1130 0         0 } else {
1131 2   66     12 return $self->{referer} ||= $self->header_in( 'referer', qr/.*/ );
1132             };
1133             };
1134              
1135             =head2 user_agent
1136              
1137             Get/set user_agent.
1138              
1139             B<[NOTE]> Avoid using user_agent for anything serious - too easy to forge.
1140              
1141             =cut
1142              
1143             sub user_agent {
1144 3     3 1 10 my $self = shift;
1145 3 50       12 if (@_) {
1146             $self->{user_agent} = shift
1147 0         0 } else {
1148             $self->{user_agent} = $self->header_in( 'user_agent', qr/.*/ )
1149 3 100       20 unless exists $self->{user_agent};
1150 3         23 return $self->{user_agent};
1151             };
1152             };
1153              
1154             =head2 content_type
1155              
1156             Returns C request header, if present, or an empty string.
1157              
1158             The usage of Content-Type in GET/HEAD requests is discouraged.
1159             See also L.
1160              
1161             =cut
1162              
1163             sub content_type {
1164 6     6 1 12 my ($self, $regex) = @_;
1165              
1166             carp ("MVC::Neaf: using content_type is discouraged for method ".$self->method)
1167 6 50       12 if ($query_allowed{$self->method});
1168              
1169 6   33     44 my $ctype = $self->header_in('content_type', $regex || qr/.*/);
1170 6 50       19 $ctype = '' unless defined $ctype;
1171              
1172 6         38 return $ctype;
1173             };
1174              
1175             =head2 dump ()
1176              
1177             Dump whatever came in the request. Useful for debugging.
1178              
1179             =cut
1180              
1181             sub dump {
1182 1     1 1 753 my $self = shift;
1183              
1184 1         2 my %raw;
1185 1         4 foreach my $method (qw( http_version scheme secure method hostname port
1186             path script_name
1187             referer user_agent )) {
1188 10         3988 $raw{$method} = eval { $self->$method }; # deliberately skip errors
  10         33  
1189             };
1190 1         3 $raw{param} = $self->_all_params;
1191 1         3 $raw{header_in} = $self->header_in->as_string;
1192 1         74 $self->get_cookie( noexist => '' ); # warm up cookie cache
1193 1         17 $raw{cookie_in} = $self->{neaf_cookie_in};
1194             $raw{path_info} = $self->{postfix}
1195 1 50       8 if defined $self->{postfix};
1196              
1197 1         4 return \%raw;
1198             };
1199              
1200             =head1 SESSION MANAGEMENT
1201              
1202             =head2 session()
1203              
1204             Get reference to session data.
1205             This reference is guaranteed to be the same throughout the request lifetime.
1206              
1207             If MVC::Neaf->set_session_handler() was called during application setup,
1208             this data will be initialized by that handler;
1209             otherwise initializes with an empty hash (or whatever session engine generates).
1210              
1211             If session engine was not provided, dies instead.
1212              
1213             See L for details about session engine internal API.
1214              
1215             =cut
1216              
1217             sub session {
1218 21     21 1 104 my $self = shift;
1219              
1220 21 100       77 if (my $sess = $self->load_session) {
1221 16         58 return $sess;
1222             };
1223              
1224 4         17 return $self->{session} = $self->_session_setup->{engine}->create_session;
1225             };
1226              
1227             =head2 load_session
1228              
1229             Like above, but don't create session - just fetch from cookies & storage.
1230              
1231             Never tries to load anything if session already loaded or created.
1232              
1233             =cut
1234              
1235             sub load_session {
1236 23     23 1 40 my $self = shift;
1237              
1238             # aggressive caching FTW
1239 23 100       89 return $self->{session} if exists $self->{session};
1240              
1241 12         37 my $setup = $self->_session_setup;
1242 12 50       39 $self->_croak("No session engine found, use Request->stash() for per-request data")
1243             unless $setup;
1244              
1245             # Try loading session...
1246 12         57 my $id = $self->get_cookie( $setup->{cookie}, $setup->{regex} );
1247 12   66     68 my $hash = ($id && $setup->{engine}->load_session( $id ));
1248              
1249 12 100       133 if (!$hash) {
    100          
    100          
1250 3         26 return;
1251             } elsif ( ref $hash ne 'HASH' ) {
1252             $self->_croak( (ref $setup->{engine})
1253 1         9 ."->load_session must return a HASH and not ".(ref $hash) );
1254             } elsif ($hash->{data} ) {
1255             # Loaded, cache it & refresh if needed
1256 7         29 $self->{session} = $hash->{data};
1257              
1258             $self->set_cookie(
1259             $setup->{cookie} => $hash->{id},
1260             expire => $hash->{expire} || $setup->{expire},
1261             )
1262 7 100 33     33 if $hash->{id};
1263             } else {
1264             carp(
1265             (ref $setup->{engine})
1266 1         16 ."->load_session must return keys(data,[id,expire]) and not "
1267             .join ",", keys %$hash
1268             );
1269             };
1270              
1271 8         543 return $self->{session};
1272             };
1273              
1274             =head2 save_session( ... )
1275              
1276             =over
1277              
1278             =item * C<$req-Esave_session( [$replace] )>
1279              
1280             =back
1281              
1282             Save whatever is in session data reference.
1283              
1284             If argument is given, replace session (if any) altogether with that one
1285             before saving.
1286              
1287             =cut
1288              
1289             sub save_session {
1290 6     6 1 31 my $self = shift;
1291              
1292 6 100       19 if (@_) {
1293 5         14 $self->{session} = shift;
1294             };
1295              
1296 6         16 my $setup = $self->_session_setup;
1297 6 50       21 return $self unless $setup;
1298              
1299             # TODO 0.90 set "save session" flag, save later
1300 6         20 my $id = $self->get_cookie( $setup->{cookie}, $setup->{regex} );
1301 6   66     62 $id ||= $setup->{engine}->get_session_id();
1302              
1303 6         24 my $hash = $setup->{engine}->save_session( $id, $self->session );
1304              
1305 6 50 33     52 if ( $hash && ref $hash eq 'HASH' ) {
1306             # save successful - send cookie to user
1307 6         12 my $expire = $hash->{expire};
1308              
1309             $self->set_cookie(
1310             $setup->{cookie} => $hash->{id} || $id,
1311             expire => $hash->{expire},
1312 6   33     48 );
1313             };
1314              
1315 6         23 return $self;
1316             };
1317              
1318             =head2 delete_session()
1319              
1320             Remove session.
1321              
1322             =cut
1323              
1324             sub delete_session {
1325 1     1 1 4 my $self = shift;
1326              
1327 1         3 my $setup = $self->_session_setup;
1328 1 50       10 return unless $setup->{engine};
1329              
1330 1         4 my $id = $self->get_cookie( $setup->{cookie}, $setup->{regex} );
1331 1 50       21 $setup->{engine}->delete_session( $id )
1332             if $id;
1333 1         5 $self->delete_cookie( $setup->{cookie} );
1334 1         3 return $self;
1335             };
1336              
1337             _helper_fallback( _session_setup => sub {
1338             my $self = shift;
1339             $self->_croak("No session engine found, use `neaf session => ...` to set up one");
1340             } );
1341              
1342             =head1 REPLY METHODS
1343              
1344             Typically, a Neaf user only needs to return a hashref with the whole reply
1345             to client.
1346              
1347             However, sometimes more fine-grained control is required.
1348              
1349             In this case, a number of methods help stashing your data
1350             (headers, cookies etc) in the request object until the response is sent.
1351              
1352             Also some lengthly actions (e.g. writing request statistics or
1353             sending confirmation e-mail) may be postponed until the request is served.
1354              
1355             =head2 header_out( ... )
1356              
1357             =over
1358              
1359             =item * C<$req-Eheader_out( [$header_name] )>
1360              
1361             =back
1362              
1363             Without parameters returns a L-compatible object
1364             containing all headers to be returned to client.
1365              
1366             With one parameter returns this header.
1367              
1368             Returned values are just proxied L returns.
1369             It is generally advised to use them in list context as multiple
1370             headers may return trash in scalar context.
1371              
1372             E.g.
1373              
1374             my @old_value = $req->header_out( foobar => set => [ "XX", "XY" ] );
1375              
1376             or
1377              
1378             my $old_value = [ $req->header_out( foobar => delete => 1 ) ];
1379              
1380             B<[NOTE]> This format may change in the future.
1381              
1382             =cut
1383              
1384             sub header_out {
1385 374     374 1 861 my $self = shift;
1386              
1387 374   66     1992 my $head = $self->{response}{header} ||= HTTP::Headers::Fast->new;
1388 374 100       3156 return $head unless @_;
1389              
1390 2         4 my $name = shift;
1391 2         5 return $head->header( $name );
1392             };
1393              
1394             =head2 set_header( ... )
1395              
1396             =head2 push_header( ... )
1397              
1398             =head2 remove_header( ... )
1399              
1400             =over
1401              
1402             =item * C<$req-Eset_header( $name, $value || [] )>
1403              
1404             =item * C<$req-Epush_header( $name, $value || [] )>
1405              
1406             =item * C<$req-Eremove_header( $name )>
1407              
1408             =back
1409              
1410             Set, append, and delete values in the header_out object.
1411             See L.
1412              
1413             Arrayrefs are fine and will set multiple values for a given header.
1414              
1415             =cut
1416              
1417             sub set_header {
1418 2     2 1 717 my ($self, $name, $value) = @_;
1419 2         6 return $self->header_out->header( $name, $value );
1420             };
1421              
1422             sub push_header {
1423 2     2 1 1287 my ($self, $name, $value) = @_;
1424 2         9 return $self->header_out->push_header( $name, $value );
1425             };
1426              
1427             sub remove_header {
1428 1     1 1 675 my ($self, $name) = @_;
1429 1         3 return $self->header_out->remove_header( $name );
1430             };
1431              
1432             =head2 reply
1433              
1434             Returns reply hashref that was returned by controller, if any.
1435             Returns C unless the controller was actually called.
1436             This may be useful in postponed actions or hooks.
1437              
1438             This is killed by a C call.
1439              
1440             =cut
1441              
1442             sub reply {
1443 378     378 1 682 my $self = shift;
1444              
1445 378         1186 return $self->{response}{ret};
1446             }
1447              
1448             sub _set_reply {
1449 162     162   560 my ($self, $data) = @_;
1450              
1451             # Cannot croak because it may point at wrong location
1452             # TODO 0.30 More suitable error message, force logging error
1453 162 100 66     1144 die "NEAF: FATAL: Controller must return hash at ".$self->endpoint_origin."\n"
1454             unless ref $data and UNIVERSAL::isa($data, 'HASH');
1455             # TODO 0.30 Also accept (&convert) hash headers
1456             die "NEAF: FATAL: '-headers' must be an even-sized array at ".$self->endpoint_origin."\n"
1457             if defined $data->{-headers}
1458 161 50 33     736 and (ref $data->{-headers} ne 'ARRAY' or @{ $data->{-headers} } % 2);
      66        
1459             Carp::cluck "NEAF: WARN: Request->_set_reply called twice, please file a bug in Neaf"
1460 161 50       577 if $self->{response}{ret};
1461              
1462 161   50     594 my $def = $self->route->default || {};
1463              
1464             # Return the resulting hash
1465 161         1454 $self->{response}{ret} = { %$def, %$data };
1466             }
1467              
1468             # TODO 0.4 should we delete {response} altogether?
1469             sub _unset_reply {
1470 48     48   114 my $self = shift;
1471 48         172 delete $self->{response}{ret};
1472             };
1473              
1474             =head2 stash( ... )
1475              
1476             Stash (ah, the naming...) is a temporary set of data that only lives
1477             throughtout request's lifetime and never gets to the client.
1478              
1479             This may be useful to maintain shared data across hooks and callbacks.
1480             Usage is as follows:
1481              
1482             =over
1483              
1484             =item * C<$req-Estash()> - get the whole stash as hash.
1485              
1486             =item * C<$req-Estash( "name" )> - get a single value
1487              
1488             =item * C<$req-Estash( %save_data )> - set multiple values, old data
1489             is overridden rather than replaced.
1490              
1491             =back
1492              
1493             As a rule of thumb,
1494              
1495             =over
1496              
1497             =item * use C if you intend to share data between requests;
1498              
1499             =item * use C if you intend to render the data for the user;
1500              
1501             =item * use C as a last resort for temporary, private data.
1502              
1503             =back
1504              
1505             Stash is not killed by C function so that cleanup hooks aren't
1506             botched accidentally.
1507              
1508             =cut
1509              
1510             sub stash {
1511 3     3 1 15 my $self = shift;
1512 3   100     10 my $st = $self->{stash} ||= {};
1513 3 100       9 return $st unless @_;
1514              
1515 2 50       12 return $st->{ $_[0] } unless @_>1;
1516              
1517 2 50       6 $self->_croak("Odd number of elements in hash assignment") if @_ % 2;
1518 2         5 my %new = @_;
1519 2         7 $st->{$_} = $new{$_} for keys %new;
1520 2         8 return $self;
1521             };
1522              
1523             =head2 postpone( ... )
1524              
1525             =over
1526              
1527             =item * C<$req-Epostpone( CODEREF-E($request) )>
1528              
1529             =item * C<$req-Epostpone( [ CODEREF-E($request), ... ] )>
1530              
1531             =back
1532              
1533             Execute a function (or several) right after the request is served.
1534              
1535             Can be called multiple times.
1536              
1537             B<[CAVEAT]> If CODEREF contains reference to the request,
1538             the request will never be destroyed due to circular reference.
1539             Thus CODEREF may not be executed.
1540              
1541             Don't pass request to CODEREF, use C instead.
1542              
1543             Returns self.
1544              
1545             =cut
1546              
1547             sub postpone {
1548 8     8 1 432 my ($self, $code, $prepend_flag) = @_;
1549              
1550 8 100       34 $code = [ $code ]
1551             unless ref $code eq 'ARRAY';
1552 8 50       19 grep { ref $_ ne 'CODE' } @$code
  10         52  
1553             and $self->_croak( "argument must be a function or a list of functions" );
1554              
1555             $prepend_flag
1556 4         18 ? unshift @{ $self->{response}{postponed} }, reverse @$code
1557 8 100       20 : push @{ $self->{response}{postponed} }, @$code;
  4         15  
1558              
1559 8         18 return $self;
1560             };
1561              
1562             =head2 write( ... )
1563              
1564             =over
1565              
1566             =item * C<$req-Ewrite( $data )>
1567              
1568             =back
1569              
1570             Write data to client inside C<-continue> callback, unless C was called.
1571              
1572             Returns self.
1573              
1574             =cut
1575              
1576             sub write {
1577 46     46 1 85 my ($self, $data) = @_;
1578              
1579             $self->{continue}
1580 46 50       80 or $self->_croak( "called outside -continue callback scope" );
1581              
1582 46 50       128 $self->do_write( $data )
1583             if defined $data;
1584 46         151 return $self;
1585             };
1586              
1587             =head2 close()
1588              
1589             Stop writing to client in C<-continue> callback.
1590              
1591             By default, does nothing, as the socket will probably
1592             be closed anyway when the request finishes.
1593              
1594             =cut
1595              
1596             sub close {
1597 3     3 1 21 my ($self) = @_;
1598              
1599             $self->{continue}
1600 3 50       12 or $self->_croak( "called outside -continue callback scope" );
1601              
1602 3         12 return $self->do_close();
1603             }
1604              
1605             =head2 clear()
1606              
1607             Remove all data that belongs to reply.
1608             This is called when a handler bails out to avoid e.g. setting cookies
1609             in a failed request.
1610              
1611             =cut
1612              
1613             sub clear {
1614 1     1 1 697 my $self = shift;
1615              
1616             $self->_croak( "called after responding" )
1617 1 50       5 if $self->{continue};
1618              
1619 1         5 delete $self->{response};
1620 1         2 return $self;
1621             }
1622              
1623             =head1 DEVELOPER METHODS
1624              
1625             =head2 id()
1626              
1627             Fetch unique request id. If none has been set yet (see L),
1628             use L method to create one.
1629              
1630             The request id is present in both log messages from Neaf
1631             and default error pages, making it easier to establish link
1632             between the two.
1633              
1634             Custom ids can be provided, see L below.
1635              
1636             =cut
1637              
1638             sub id {
1639 71     71 1 1621 my $self = shift;
1640              
1641             # We don't really need to protect anything here
1642             # Just avoid accidental matches for which md5 seems good enough
1643 71   66     455 return $self->{id} ||= $self->make_id;
1644             };
1645              
1646             =head2 set_id( ... )
1647              
1648             =over
1649              
1650             =item * C<$req-Eset_id( $new_value )>
1651              
1652             =back
1653              
1654             Set the id above to a user-supplied value.
1655              
1656             If a false value given, just generate a new one next time id is requested.
1657              
1658             Symbols outside C, as well as whitespace and C<"> and C"\",
1659             are prohibited.
1660              
1661             Returns the request object.
1662              
1663             =cut
1664              
1665             sub set_id {
1666 1     1 1 6 my ($self, $id) = @_;
1667              
1668 1 50 33     15 !$id or $id =~ /^[\x21-\x7E]+$/ && $id !~ /[\s\"\\]/
      33        
1669             or $self->_croak( "Bad id format, should only contain printable" );
1670              
1671 1         3 $self->{id} = $id;
1672 1         3 return $self;
1673             };
1674              
1675             =head2 log_error( ... )
1676              
1677             =over
1678              
1679             =item * C<$req-Elog_error( $message )>
1680              
1681             =back
1682              
1683             Log an error message, annotated with request id and the route being processed.
1684              
1685             Currently works via warn, but this may change in the future.
1686              
1687             B<[EXPERIMENTAL]> This feature is still under development.
1688              
1689             One can count on C to be available in the future and do
1690             some king of logging.
1691              
1692             =cut
1693              
1694             sub log_error {
1695 20     20 1 96 my ($self, $msg) = @_;
1696 20         114 $self->log_message( error => $msg );
1697             };
1698              
1699             =head2 execute_postponed()
1700              
1701             NOT TO BE CALLED BY USER.
1702              
1703             Execute postponed functions. This is called in DESTROY by default,
1704             but request driver may decide it knows better.
1705              
1706             Flushes postponed queue. Ignores exceptions in functions being executed.
1707              
1708             Returns self.
1709              
1710             =cut
1711              
1712             sub execute_postponed {
1713 6     6 1 15 my $self = shift;
1714              
1715 6         23 $self->{continue}++;
1716             run_all_nodie( delete $self->{response}{postponed}, sub {
1717             # TODO 0.30 prettier error handling
1718 0     0   0 carp "NEAF WARN ".(ref $self).": postponed action failed: $@";
1719 6         57 }, $self );
1720              
1721 6         55 return $self;
1722             };
1723              
1724              
1725             sub _mangle_headers {
1726 157     157   334 my $self = shift;
1727              
1728 157         522 my $data = $self->reply;
1729 157         410 my $content = \$data->{-content};
1730              
1731 157 50       467 confess "NEAF: No content after request processing. File a bug in MVC::Neaf"
1732             unless defined $$content;
1733              
1734             # Process user-supplied headers
1735 157 100       541 if (my $append = $data->{-headers}) {
1736 48         337 my $head = $self->header_out;
1737 48         243 for (my $i = 0; $i < @$append; $i+=2) {
1738 11         82 $head->push_header($append->[$i], $append->[$i+1]);
1739             };
1740             };
1741              
1742             # TODO 0.30 do something with this regex mess - its complicated & dog slow
1743             # Encode unicode content NOW so that we don't lie about its length
1744             # Then detect ascii/binary
1745 157 100       1963 if (Encode::is_utf8( $$content )) {
    100          
    100          
1746             # UTF8 means text, period
1747 48         217 $$content = encode_utf8( $$content );
1748 48   100     195 $data->{-type} ||= 'text/plain';
1749             $data->{-type} .= "; charset=utf-8"
1750 48 100       323 unless $data->{-type} =~ /; charset=/;
1751             } elsif (!$data->{-type}) {
1752             # Autodetect binary. Plain text is believed to be in utf8 still
1753 50 100       342 $data->{-type} = $$content =~ /^.{0,512}?[^\s\x20-\x7F]/s
1754             ? 'application/octet-stream'
1755             : 'text/plain; charset=utf-8';
1756             } elsif ($data->{-type} =~ m#^text/#) {
1757             # Some other text, mark as utf-8 just in case
1758             $data->{-type} .= "; charset=utf-8"
1759 54 100       373 unless $data->{-type} =~ /; charset=/;
1760             };
1761              
1762             # MANGLE HEADERS
1763 157         726 my $head = $self->header_out;
1764              
1765             # The most standard ones...
1766 157         817 $head->init_header( content_type => $data->{-type} );
1767             $head->init_header( location => $data->{-location} )
1768 157 50       7193 if $data->{-location};
1769 157         815 $head->push_header( set_cookie => $self->format_cookies );
1770             $head->init_header( content_length => length $$content )
1771 157 100       6732 unless $data->{-continue};
1772              
1773             # TODO 0.30 must be hook
1774 157 100 100     5619 if ($data->{-status} == 200 and my $ttl = $self->route->cache_ttl) {
1775 3         17 $head->init_header( expires => http_date( time + $ttl ) );
1776             };
1777              
1778             # END MANGLE HEADERS
1779             };
1780              
1781             # Apply route's pre_reply & pre_cleanup hooks to self, if any
1782             sub _apply_late_hooks {
1783 157     157   345 my $self = shift;
1784              
1785 157         432 my $route = $self->route;
1786 157 100       506 if (my $hooks = $route->hooks->{pre_cleanup}) {
1787 3         11 $self->postpone( $hooks );
1788             };
1789 157 100       595 if (my $hooks = $route->hooks->{pre_reply}) {
1790             run_all_nodie( $hooks, sub {
1791 1     1   5 $self->log_error( "NEAF: pre_reply hook failed: $@" )
1792 5         43 }, $self );
1793             };
1794             };
1795              
1796             # Dispatch headers & content
1797             # This is called at the end of handle_request
1798             sub _respond {
1799 157     157   331 my $self = shift;
1800              
1801             # TODO 0.30 kill do_reply, simplify this
1802 157         464 my $data = $self->reply;
1803              
1804 157 100       453 if( $self->method eq 'HEAD' ) {
    100          
1805 1         5 return $self->do_reply( $data->{-status}, '' );
1806             } elsif ( $data->{-continue} ) {
1807 2         33 $self->postpone( $data->{-continue}, 1 );
1808 2     2   27 $self->postpone( sub { $_[0]->write( $data->{-content} ); }, 1 );
  2         13  
1809 2         10 return $self->do_reply( $data->{-status} );
1810             } else {
1811 154         804 return $self->do_reply( $data->{-status}, $data->{-content} );
1812             };
1813             };
1814              
1815             sub DESTROY {
1816 167     167   33944 my $self = shift;
1817              
1818             # TODO 0.90 Check that request isn't destroyed because of an exception
1819             # during sending headers
1820             # In this case we're gonna fail silently with cryptic warnings. :(
1821             $self->execute_postponed
1822 167 100       4416 if (exists $self->{response}{postponed});
1823             };
1824              
1825             =head1 METHODS THAT CAN BE OVERRIDDEN
1826              
1827             Generally Neaf allows to define custom Request methods restricted to certain
1828             path & method combinations.
1829              
1830             The following methods are available by default, but can be overridden
1831             via the helper mechanism.
1832              
1833             For instance,
1834              
1835             use MVC::Neaf;
1836              
1837             my $id;
1838             neaf helper => make_id => sub { $$ . "_" . ++$id };
1839             neaf helper => make_id => \&unique_secure_base64, path => '/admin';
1840              
1841             =cut
1842              
1843             sub _helper_fallback {
1844 470     470   1081 my ($name, $impl) = @_;
1845              
1846             my $code = sub {
1847 95     95   218 my $self = shift;
1848 95   66     291 my $todo = $self->route && $self->route->helpers->{$name} || $impl;
1849 95         350 $todo->( $self, @_ );
1850 470         1482 };
1851              
1852 470         1065 $allow_helper{$name}++;
1853              
1854 94     94   929 no strict 'refs'; ## no critic
  94         219  
  94         3922  
1855 94     94   654 use warnings FATAL => qw(all);
  94         319  
  94         31837  
1856 470         1717 *$name = $code;
1857             };
1858              
1859             =head2 make_id
1860              
1861             Create unique request id, e.g. for logging context.
1862             This is called by L if the id has not yet been set.
1863              
1864             By default, generates MD5 checksum based on time, hostname, process id, and a
1865             sequential number and encodes as URL-friendly base64.
1866              
1867             B<[CAUTION]> This should be unique, but may not be secure.
1868             Use L if you need something to rely upon.
1869              
1870             =cut
1871              
1872             my $host = Sys::Hostname::hostname();
1873             my $lastid = 0;
1874             _helper_fallback( make_id => sub {
1875             $lastid = 0 if $lastid > 4_000_000_000;
1876             encode_b64( md5( join "#", $host, $$, Time::HiRes::time, ++$lastid ) );
1877             } );
1878              
1879             =head2 log_message
1880              
1881             $req->log_message( $level => $message );
1882              
1883             By default would print uppercased level, $request->id, route,
1884             and the message itself.
1885              
1886             Levels are not restricted whatsoever.
1887             Suggested values are "fatal", "error", "warn", "debug".
1888              
1889             =cut
1890              
1891             _helper_fallback( log_message => sub {
1892             my ($req, $level, $mess) = @_;
1893              
1894             $mess = Carp::shortmess("(undef)")
1895             unless defined $mess;
1896             $mess =~ s/\n+$//s;
1897              
1898             warn sprintf "%s req_id=%s [%s]: %s\n"
1899             , uc $level, $req->id, $req->route->path, $mess;
1900             });
1901              
1902             =head1 DRIVER METHODS
1903              
1904             The following methods MUST be implemented in every Request subclass
1905             to create a working Neaf backend.
1906              
1907             They SHOULD NOT be called directly inside the application.
1908              
1909             =over
1910              
1911             =item * do_get_client_ip()
1912              
1913             =item * do_get_http_version()
1914              
1915             =item * do_get_method()
1916              
1917             =item * do_get_scheme()
1918              
1919             =item * do_get_hostname()
1920              
1921             =item * do_get_port()
1922              
1923             =item * do_get_path()
1924              
1925             =item * do_get_params()
1926              
1927             =item * do_get_param_as_array() - get single GET/POST parameter in list context
1928              
1929             =item * do_get_upload()
1930              
1931             =item * do_get_body()
1932              
1933             =item * do_get_header_in() - returns a L-compatible object.
1934              
1935             =item * do_reply( $status, $content ) - write reply to client
1936              
1937             =item * do_reply( $status ) - only send headers to client
1938              
1939             =item * do_write( $data )
1940              
1941             =item * do_close()
1942              
1943             =back
1944              
1945             =cut
1946              
1947             foreach (qw(
1948             do_get_method do_get_scheme do_get_hostname do_get_port do_get_path
1949             do_get_client_ip do_get_http_version
1950             do_get_params do_get_param_as_array do_get_upload do_get_header_in
1951             do_get_body
1952             do_reply do_write)) {
1953             my $method = $_;
1954             my $code = sub {
1955 6     6   7 my $self = shift;
1956 6   33     63 croak ((ref $self || $self)."->$method() unimplemented!");
1957             };
1958 94     94   794 no strict 'refs'; ## no critic
  94         251  
  94         15461  
1959             *$method = $code;
1960             };
1961              
1962             # by default, just skip - the handle will auto-close anyway at some point
1963 1     1 1 3 sub do_close { return 1 };
1964              
1965             sub _croak {
1966 6     6   22 my ($self, $msg) = @_;
1967              
1968 6         41 my $where = [caller(1)]->[3];
1969 6         182 $where =~ s/.*:://;
1970 6   33     661 croak( (ref $self || $self)."->$where: $msg" );
1971             };
1972              
1973             =head1 DEPRECATED METHODS
1974              
1975             Some methods become obsolete during Neaf development.
1976             Anything that is considered deprecated will continue to be supported
1977             I after official deprecation
1978             and a corresponding warning being added.
1979              
1980             Please keep an eye on C though.
1981              
1982             Here are these methods, for the sake of completeness.
1983              
1984             =cut
1985              
1986             =head2 script_name
1987              
1988             See L
1989              
1990             =head2 path_info
1991              
1992             See L.
1993              
1994             =head2 path_info_split
1995              
1996             See L
1997              
1998             These three will start warning in 0.30 and will be removed in 0.40
1999              
2000             =cut
2001              
2002             # TODO 0.30 start warning "deprecated"
2003             {
2004 94     94   812 no warnings 'once'; ## no critic
  94         272  
  94         4991  
2005 94     94   634 use warnings FATAL => 'redefine';
  94         252  
  94         30244  
2006             *script_name = \&prefix;
2007             *path_info = \&postfix;
2008             *path_info_split = \&splat;
2009             }
2010              
2011             =head2 header_in_keys ()
2012              
2013             Return all keys in header_in object as a list.
2014              
2015             B<[DEPRECATED]> Use C<$req-Eheader_in-Eheader_field_names> instead.
2016              
2017             =cut
2018              
2019             sub header_in_keys {
2020 1     1 1 72 my $self = shift;
2021              
2022 1         19 carp( (ref $self)."->header_in_keys: DEPRECATED, use header_in()->header_field_names instead" );
2023 1         563 my $head = $self->header_in;
2024 1         5 $head->header_field_names;
2025             };
2026              
2027             =head2 endpoint_origin
2028              
2029             Returns file:line where controller was defined.
2030              
2031             B<[DEPRECATED]> This function was added prematurely and shall not be used.
2032              
2033             =cut
2034              
2035             sub endpoint_origin {
2036 4     4 1 12 my $self = shift;
2037              
2038 4 50       27 return '(unspecified file):0' unless $self->{route}{caller};
2039 4         10 return join " line ", @{ $self->{route}{caller} }[1,2];
  4         50  
2040             };
2041              
2042             =head2 get_form_as_hash( ... )
2043              
2044             =over
2045              
2046             =item * C<$req-Eget_form_as_hash( name =E qr/.../, name2 =E qr/..../, ... )>
2047              
2048             =back
2049              
2050             B<[DEPRECATED]> and dies. Use L instead.
2051              
2052             =cut
2053              
2054             sub get_form_as_hash {
2055 1     1 1 18 my ($self, %spec) = @_;
2056              
2057 1         5 $self->_croak( "DEPRECATED. use neaf->add_form( name, ...) + \$req->form( name )" );
2058             };
2059              
2060             =head2 set_default( ... )
2061              
2062             =over
2063              
2064             =item * C<$req-Eset_default( key =E $value, ... )>
2065              
2066             =back
2067              
2068             As of v.0.20 this dies.
2069              
2070             Use path-based defaults, or stash().
2071              
2072             =cut
2073              
2074             sub set_default {
2075 1     1 1 56 my ($self, %args) = @_;
2076              
2077             # TODO 0.30 remove completely
2078 1         4 $self->_croak( "DEPRECATED. Use path-based defaults or stash()" );
2079             };
2080              
2081             =head2 get_default()
2082              
2083             As of v.0.20 this dies.
2084              
2085             Use path-based defaults, or stash().
2086              
2087             =cut
2088              
2089             sub get_default {
2090 1     1 1 1547 my $self = shift;
2091              
2092             # TODO 0.30 remove completely
2093 1         3 $self->_croak( "DEPRECATED. Use path-based defaults or stash()" );
2094             };
2095              
2096             =head1 LICENSE AND COPYRIGHT
2097              
2098             This module is part of L suite.
2099              
2100             Copyright 2016-2023 Konstantin S. Uvarin C.
2101              
2102             This program is free software; you can redistribute it and/or modify it
2103             under the terms of either: the GNU General Public License as published
2104             by the Free Software Foundation; or the Artistic License.
2105              
2106             See L for more information.
2107              
2108             =cut
2109              
2110             1;