File Coverage

blib/lib/Mojo/Transaction/HTTP.pm
Criterion Covered Total %
statement 64 64 100.0
branch 45 52 86.5
condition 27 28 96.4
subroutine 13 13 100.0
pod 8 8 100.0
total 157 165 95.1


line stmt bran cond sub pod time code
1             package Mojo::Transaction::HTTP;
2 55     55   1493 use Mojo::Base 'Mojo::Transaction';
  55         135  
  55         387  
3              
4             has 'previous';
5              
6             sub client_read {
7 962     962 1 2460 my ($self, $chunk) = @_;
8              
9             # Skip body for HEAD request
10 962         2969 my $res = $self->res;
11 962 100       3310 $res->content->skip_body(1) if uc $self->req->method eq 'HEAD';
12 962 100       3535 return undef unless $res->parse($chunk)->is_finished;
13              
14             # Unexpected 1xx response
15 925 100 100     3202 return $self->completed if !$res->is_info || $res->headers->upgrade;
16 2         9 $self->res($res->new)->emit(unexpected => $res);
17 2 50       8 return undef unless length(my $leftovers = $res->content->leftovers);
18 2         25 $self->client_read($leftovers);
19             }
20              
21 1989     1989 1 5140 sub client_write { shift->_write(0) }
22              
23 954   100 954 1 3551 sub is_empty { !!(uc $_[0]->req->method eq 'HEAD' || $_[0]->res->is_empty) }
24              
25             sub keep_alive {
26 1817     1817 1 3306 my $self = shift;
27              
28             # Close
29 1817         4097 my $req = $self->req;
30 1817         4186 my $res = $self->res;
31 1817   100     4934 my $req_conn = lc($req->headers->connection // '');
32 1817   100     4866 my $res_conn = lc($res->headers->connection // '');
33 1817 100 100     7741 return undef if $req_conn eq 'close' || $res_conn eq 'close';
34              
35             # Keep-alive is optional for 1.0
36 1772 100       4926 return $res_conn eq 'keep-alive' if $res->version eq '1.0';
37 1763 100       4554 return $req_conn eq 'keep-alive' if $req->version eq '1.0';
38              
39             # Keep-alive is the default for 1.1
40 1760         8968 return 1;
41             }
42              
43             sub redirects {
44 31     31 1 69 my $previous = shift;
45 31         52 my @redirects;
46 31         91 unshift @redirects, $previous while $previous = $previous->previous;
47 31         155 return \@redirects;
48             }
49              
50 1072 50   1072 1 5848 sub resume { ++$_[0]{writing} and return $_[0]->emit('resume') }
51              
52             sub server_read {
53 1013     1013 1 2862 my ($self, $chunk) = @_;
54              
55             # Parse request
56 1013         2700 my $req = $self->req;
57 1013 50       3787 $req->parse($chunk) unless $req->error;
58              
59             # Generate response
60 1013 100 66     2865 $self->emit('request') if $req->is_finished && !$self->{handled}++;
61             }
62              
63 1837     1837 1 4771 sub server_write { shift->_write(1) }
64              
65             sub _body {
66 2818     2818   5771 my ($self, $msg, $finish) = @_;
67              
68             # Prepare body chunk
69 2818         8639 my $buffer = $msg->get_body_chunk($self->{offset});
70 2818 100       7559 $self->{offset} += defined $buffer ? length $buffer : 0;
71              
72             # Delayed
73 2818 100       6125 $self->{writing} = 0 unless defined $buffer;
74              
75             # Finished
76 2818 100 100     13967 $finish ? $self->completed : ($self->{writing} = 0) if defined $buffer && !length $buffer;
    100          
77              
78 2818   100     9613 return $buffer // '';
79             }
80              
81             sub _headers {
82 1868     1868   4403 my ($self, $msg, $head) = @_;
83              
84             # Prepare header chunk
85 1868         6457 my $buffer = $msg->get_header_chunk($self->{offset});
86 1868 50       4922 my $written = defined $buffer ? length $buffer : 0;
87 1868         3464 $self->{write} -= $written;
88 1868         3266 $self->{offset} += $written;
89              
90             # Switch to body
91 1868 50       4547 if ($self->{write} <= 0) {
92 1868         3946 @$self{qw(http_state offset)} = ('body', 0);
93              
94             # Response without body
95 1868 100 100     6276 $self->completed->{http_state} = 'empty' if $head && $self->is_empty;
96             }
97              
98 1868         5876 return $buffer;
99             }
100              
101             sub _start_line {
102 1868     1868   4009 my ($self, $msg) = @_;
103              
104             # Prepare start-line chunk
105 1868         6218 my $buffer = $msg->get_start_line_chunk($self->{offset});
106 1868 50       4664 my $written = defined $buffer ? length $buffer : 0;
107 1868         3387 $self->{write} -= $written;
108 1868         3082 $self->{offset} += $written;
109              
110             # Switch to headers
111 1868 50       7580 @$self{qw(http_state write offset)} = ('headers', $msg->header_size, 0) if $self->{write} <= 0;
112              
113 1868         5128 return $buffer;
114             }
115              
116             sub _write {
117 3826     3826   7062 my ($self, $server) = @_;
118              
119             # Client starts writing right away
120 3826 100 100     15611 return '' unless $server ? $self->{writing} : ($self->{writing} //= 1);
    100          
121              
122             # Nothing written yet
123 2910   100     17532 $self->{$_} ||= 0 for qw(offset write);
124 2910 100       9944 my $msg = $server ? $self->res : $self->req;
125 2910 100       12762 @$self{qw(http_state write)} = ('start_line', $msg->start_line_size) unless $self->{http_state};
126              
127             # Start-line
128 2910         5568 my $chunk = '';
129 2910 100       9386 $chunk .= $self->_start_line($msg) if $self->{http_state} eq 'start_line';
130              
131             # Headers
132 2910 100       10071 $chunk .= $self->_headers($msg, $server) if $self->{http_state} eq 'headers';
133              
134             # Body
135 2910 100       9932 $chunk .= $self->_body($msg, $server) if $self->{http_state} eq 'body';
136              
137 2910         10265 return $chunk;
138             }
139              
140             1;
141              
142             =encoding utf8
143              
144             =head1 NAME
145              
146             Mojo::Transaction::HTTP - HTTP transaction
147              
148             =head1 SYNOPSIS
149              
150             use Mojo::Transaction::HTTP;
151              
152             # Client
153             my $tx = Mojo::Transaction::HTTP->new;
154             $tx->req->method('GET');
155             $tx->req->url->parse('http://example.com');
156             $tx->req->headers->accept('application/json');
157             say $tx->res->code;
158             say $tx->res->headers->content_type;
159             say $tx->res->body;
160             say $tx->remote_address;
161              
162             # Server
163             my $tx = Mojo::Transaction::HTTP->new;
164             say $tx->req->method;
165             say $tx->req->url->to_abs;
166             say $tx->req->headers->accept;
167             say $tx->remote_address;
168             $tx->res->code(200);
169             $tx->res->headers->content_type('text/plain');
170             $tx->res->body('Hello World!');
171              
172             =head1 DESCRIPTION
173              
174             L is a container for HTTP transactions, based on L
175             7230|https://tools.ietf.org/html/rfc7230> and L.
176              
177             =head1 EVENTS
178              
179             L inherits all events from L and can emit the following new ones.
180              
181             =head2 request
182              
183             $tx->on(request => sub ($tx) {...});
184              
185             Emitted when a request is ready and needs to be handled.
186              
187             $tx->on(request => sub ($tx) { $tx->res->headers->header('X-Bender' => 'Bite my shiny metal ass!') });
188              
189             =head2 resume
190              
191             $tx->on(resume => sub ($tx) {...});
192              
193             Emitted when transaction is resumed.
194              
195             =head2 unexpected
196              
197             $tx->on(unexpected => sub ($tx, $res) {...});
198              
199             Emitted for unexpected C<1xx> responses that will be ignored.
200              
201             $tx->on(unexpected => sub ($tx) { $tx->res->on(finish => sub { say 'Follow-up response is finished.' }) });
202              
203             =head1 ATTRIBUTES
204              
205             L inherits all attributes from L and implements the following new ones.
206              
207             =head2 previous
208              
209             my $previous = $tx->previous;
210             $tx = $tx->previous(Mojo::Transaction::HTTP->new);
211              
212             Previous transaction that triggered this follow-up transaction, usually a L object.
213              
214             # Paths of previous requests
215             say $tx->previous->previous->req->url->path;
216             say $tx->previous->req->url->path;
217              
218             =head1 METHODS
219              
220             L inherits all methods from L and implements the following new ones.
221              
222             =head2 client_read
223              
224             $tx->client_read($bytes);
225              
226             Read data client-side, used to implement user agents such as L.
227              
228             =head2 client_write
229              
230             my $bytes = $tx->client_write;
231              
232             Write data client-side, used to implement user agents such as L.
233              
234             =head2 is_empty
235              
236             my $bool = $tx->is_empty;
237              
238             Check transaction for C request and C<1xx>, C<204> or C<304> response.
239              
240             =head2 keep_alive
241              
242             my $bool = $tx->keep_alive;
243              
244             Check if connection can be kept alive.
245              
246             =head2 redirects
247              
248             my $redirects = $tx->redirects;
249              
250             Return an array reference with all previous transactions that preceded this follow-up transaction.
251              
252             # Paths of all previous requests
253             say $_->req->url->path for @{$tx->redirects};
254              
255             =head2 resume
256              
257             $tx = $tx->resume;
258              
259             Resume transaction.
260              
261             =head2 server_read
262              
263             $tx->server_read($bytes);
264              
265             Read data server-side, used to implement web servers such as L.
266              
267             =head2 server_write
268              
269             my $bytes = $tx->server_write;
270              
271             Write data server-side, used to implement web servers such as L.
272              
273             =head1 SEE ALSO
274              
275             L, L, L.
276              
277             =cut