File Coverage

blib/lib/Net/Async/HTTP/Server/Request.pm
Criterion Covered Total %
statement 100 105 95.2
branch 21 30 70.0
condition n/a
subroutine 33 34 97.0
pod 21 23 91.3
total 175 192 91.1


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2013-2020 -- leonerd@leonerd.org.uk
5              
6             package Net::Async::HTTP::Server::Request;
7              
8 12     12   84 use strict;
  12         22  
  12         309  
9 12     12   49 use warnings;
  12         21  
  12         416  
10              
11             our $VERSION = '0.13';
12              
13 12     12   60 use Carp;
  12         28  
  12         654  
14              
15 12     12   90 use URI;
  12         42  
  12         367  
16 12     12   4603 use URI::QueryParam;
  12         7992  
  12         13284  
17              
18             my $CRLF = "\x0d\x0a";
19              
20             =head1 NAME
21              
22             C - represents a single outstanding request
23              
24             =head1 DESCRIPTION
25              
26             Objects in this class represent a single outstanding request received by a
27             L instance. It allows access to the data received
28             from the web client and allows responding to it.
29              
30             =cut
31              
32             sub new
33             {
34 24     24 0 47 my $class = shift;
35 24         57 my ( $conn, $request ) = @_;
36              
37 24         189 return bless {
38             conn => $conn,
39             req => $request,
40              
41             pending => [],
42             bytes_written => 0,
43             is_done => 0,
44             is_closed => 0,
45             }, $class;
46             }
47              
48             =head1 METHODS
49              
50             =cut
51              
52             =head2 is_closed
53              
54             $is_closed = $request->is_closed
55              
56             Returns true if the underlying network connection for this request has already
57             been closed. If this is the case, the application is free to drop the request
58             object and perform no further processing on it.
59              
60             =cut
61              
62             sub _close
63             {
64 1     1   3 my $self = shift;
65 1         3 $self->{is_closed} = 1;
66             }
67              
68             sub is_closed
69             {
70 3     3 1 475 my $self = shift;
71 3         10 return $self->{is_closed};
72             }
73              
74             =head2 method
75              
76             $method = $request->method
77              
78             Return the method name from the request header.
79              
80             =cut
81              
82             sub method
83             {
84 25     25 1 1289 my $self = shift;
85 25         99 return $self->{req}->method;
86             }
87              
88             =head2 path
89              
90             $path = $request->path
91              
92             Return the path name from the request header.
93              
94             =cut
95              
96             sub path
97             {
98 24     24 1 579 my $self = shift;
99 24         55 return $self->{req}->uri->path;
100             }
101              
102             =head2 query_string
103              
104             $query_string = $request->query_string
105              
106             Return the query string from the request header.
107              
108             =cut
109              
110             sub query_string
111             {
112 10     10 1 531 my $self = shift;
113 10         29 return $self->{req}->uri->query;
114             }
115              
116             =head2 query_form
117              
118             %params = $request->query_form
119              
120             I
121              
122             Return an even-sized list of name and value pairs that gives the decoded data
123             in the query string. This is the same format as the same-named method on
124             L.
125              
126             =cut
127              
128             sub query_form
129             {
130 1     1 1 466 my $self = shift;
131 1         4 return $self->{req}->uri->query_form;
132             }
133              
134             =head2 query_param_names
135              
136             @names = $request->query_param_names
137              
138             I
139              
140             Return a list of the names of all the query parameters.
141              
142             =cut
143              
144             sub query_param_names
145             {
146 1     1 1 542 my $self = shift;
147 1         30 return $self->{req}->uri->query_param;
148             }
149              
150             =head2 query_param
151              
152             $value = $request->query_param( $name )
153              
154             @values = $request->query_param( $name )
155              
156             I
157              
158             Return the value or values of a single decoded query parameter.
159              
160             =cut
161              
162             sub query_param
163             {
164 1     1 1 517 my $self = shift;
165 1         5 return $self->{req}->uri->query_param( @_ );
166             }
167              
168             =head2 protocol
169              
170             $protocol = $request->protocol
171              
172             Return the protocol version from the request header. This will be the full
173             string, such as C.
174              
175             =cut
176              
177             sub protocol
178             {
179 58     58 1 1824 my $self = shift;
180 58         172 return $self->{req}->protocol;
181             }
182              
183             =head2 header
184              
185             $value = $request->header( $key )
186              
187             Return the value of a request header.
188              
189             =cut
190              
191             sub header
192             {
193 1     1 1 515 my $self = shift;
194 1         4 my ( $key ) = @_;
195 1         11 return $self->{req}->header( $key );
196             }
197              
198             =head2 headers
199              
200             @headers = $request->headers
201              
202             Returns a list of 2-element C refs containing all the request headers.
203             Each referenced array contains, in order, the name and the value.
204              
205             =cut
206              
207             sub headers
208             {
209 10     10 1 536 my $self = shift;
210 10         15 my @headers;
211              
212             $self->{req}->scan( sub {
213 5     5   145 my ( $name, $value ) = @_;
214 5         41 push @headers, [ $name, $value ];
215 10         121 } );
216              
217 10         209 return @headers;
218             }
219              
220             =head2 body
221              
222             $body = $request->body
223              
224             Return the body content from the request as a string of bytes.
225              
226             =cut
227              
228             sub body
229             {
230 14     14 1 97 my $self = shift;
231 14         62 return $self->{req}->content;
232             }
233              
234             # Called by NaHTTP::Server::Protocol
235             sub _write_to_stream
236             {
237 59     59   82 my $self = shift;
238 59         99 my ( $stream ) = @_;
239              
240 59         76 while( defined( my $next = shift @{ $self->{pending} } ) ) {
  96         5333  
241             $stream->write( $next,
242             on_write => sub {
243 40     40   17787 $self->{bytes_written} += $_[1];
244             },
245             $self->protocol eq "HTTP/1.0" ?
246 37 100   1   171 ( on_flush => sub { $stream->close } ) :
  1         60  
247             (),
248             );
249             }
250              
251             # An empty ->write to ensure we capture the written byte count correctly
252             $stream->write( "",
253             on_write => sub {
254 19     19   5268 $self->{conn}->parent->_done_request( $self );
255             }
256 59 100       218 ) if $self->{is_done};
257              
258 59         1354 return $self->{is_done};
259             }
260              
261             =head2 write
262              
263             $request->write( $data )
264              
265             Append more data to the response to be written to the client. C<$data> can
266             either be a plain string, or a C reference to be used in the underlying
267             L's C method.
268              
269             =cut
270              
271             sub write
272             {
273 40     40 1 1562 my $self = shift;
274 40         175 my ( $data ) = @_;
275              
276 40 100       113 unless( defined $self->{response_status_line} ) {
277 21         160 ( $self->{response_status_line} ) = split m/$CRLF/, $data;
278             }
279              
280 40 100       111 return if $self->{is_closed};
281              
282 38 50       91 $self->{is_done} and croak "This request has already been completed";
283              
284 38         52 push @{ $self->{pending} }, $data;
  38         90  
285 38         117 $self->{conn}->_flush_requests;
286             }
287              
288             =head2 write_chunk
289              
290             $request->write_chunk( $data )
291              
292             Append more data to the response in the form of an HTTP chunked-transfer
293             chunk. This convenience is a shortcut wrapper for prepending the chunk header.
294              
295             =cut
296              
297             sub write_chunk
298             {
299 6     6 1 2120 my $self = shift;
300 6         14 my ( $data ) = @_;
301              
302 6 50       16 return if $self->{is_closed};
303 6 100       17 return unless my $len = length $data; # Must not write zero-byte chunks
304              
305 5         30 $self->write( sprintf "%X$CRLF%s$CRLF", $len, $data );
306             }
307              
308             =head2 done
309              
310             $request->done
311              
312             Marks this response as completed.
313              
314             =cut
315              
316             sub done
317             {
318 22     22 1 74 my $self = shift;
319              
320 22 100       68 return if $self->{is_closed};
321              
322 20 50       58 $self->{is_done} and croak "This request has already been completed";
323              
324 20         35 $self->{is_done} = 1;
325 20         50 $self->{conn}->_flush_requests;
326             }
327              
328             =head2 write_chunk_eof
329              
330             $request->write_chunk_eof
331              
332             Sends the final EOF chunk and marks this response as completed.
333              
334             =cut
335              
336             sub write_chunk_eof
337             {
338 3     3 1 2458 my $self = shift;
339              
340 3 50       11 return if $self->{is_closed};
341              
342 3         13 $self->write( "0$CRLF$CRLF" );
343 3         10 $self->done;
344             }
345              
346             =head2 as_http_request
347              
348             $req = $request->as_http_request
349              
350             Returns the data of the request as an L object.
351              
352             =cut
353              
354             sub as_http_request
355             {
356 1     1 1 111 my $self = shift;
357 1         2 return $self->{req};
358             }
359              
360             =head2 respond
361              
362             $request->respond( $response )
363              
364             Respond to the request using the given L object.
365              
366             =cut
367              
368             sub respond
369             {
370 0     0 1 0 my $self = shift;
371 0         0 my ( $response ) = @_;
372              
373 0 0       0 defined $response->protocol or
374             $response->protocol( $self->protocol );
375              
376 0         0 $self->write( $response->as_string( $CRLF ) );
377 0         0 $self->done;
378             }
379              
380             =head2 respond_chunk_header
381              
382             $request->respond_chunk_header( $response )
383              
384             Respond to the request using the given L object to send in
385             HTTP/1.1 chunked encoding mode.
386              
387             The headers in the C<$response> will be sent (which will be modified to set
388             the C header). Each call to C will send
389             another chunk of data. C will send the final EOF chunk and
390             mark the request as complete.
391              
392             If the C<$response> already contained content, that will be sent as one chunk
393             immediately after the header is sent.
394              
395             =cut
396              
397             sub respond_chunk_header
398             {
399 2     2 1 467 my $self = shift;
400 2         5 my ( $response ) = @_;
401              
402 2 50       7 defined $response->protocol or
403             $response->protocol( $self->protocol );
404 2 50       32 defined $response->header( "Transfer-Encoding" ) or
405             $response->header( "Transfer-Encoding" => "chunked" );
406              
407 2         169 my $content = $response->content;
408              
409 2         26 my $header = $response->as_string( $CRLF );
410             # Trim any content from the header as it would need to be chunked
411 2         265 $header =~ s/$CRLF$CRLF.*$/$CRLF$CRLF/s;
412              
413 2         8 $self->write( $header );
414              
415 2 100       5 $self->write_chunk( $response->content ) if length $response->content;
416             }
417              
418             =head2 stream
419              
420             $stream = $request->stream
421              
422             Returns the L object representing this connection. Usually
423             this would be used for such things as inspecting the client's connection
424             address on the C of the stream. It should not be necessary to
425             directly perform IO operations on this stream itself.
426              
427             =cut
428              
429             sub stream
430             {
431 9     9 1 16 my $self = shift;
432 9         28 return $self->{conn};
433             }
434              
435             =head2 response_status_line
436              
437             $status = $request->response_status_line
438              
439             If a response header has been written by calling the C method, returns
440             the first line of it.
441              
442             =cut
443              
444             sub response_status_line
445             {
446 1     1 1 2 my $self = shift;
447 1         4 return $self->{response_status_line};
448             }
449              
450             =head2 response_status_code
451              
452             $code = $request->response_status_code
453              
454             If a response header has been written by calling the C method, returns
455             the status code from it.
456              
457             =cut
458              
459             sub response_status_code
460             {
461 2     2 1 13 my $self = shift;
462 2 50       9 my $line = $self->{response_status_line} or return undef;
463 2         13 return +( split m/ /, $line )[1];
464             }
465              
466             # For metrics
467             sub bytes_written
468             {
469 1     1 0 2 my $self = shift;
470 1         3 return $self->{bytes_written};
471             }
472              
473             =head1 AUTHOR
474              
475             Paul Evans
476              
477             =cut
478              
479             0x55AA;