package Mojo::Transaction::HTTP; use Mojo::Base 'Mojo::Transaction'; use Mojo::Transaction::WebSocket; has 'previous'; sub client_read { my ($self, $chunk) = @_; # Skip body for HEAD request my $res = $self->res; $res->content->skip_body(1) if uc $self->req->method eq 'HEAD'; return unless $res->parse($chunk)->is_finished; # Unexpected 1xx response return $self->{state} = 'finished' if !$res->is_status_class(100) || $res->headers->upgrade; $self->res($res->new)->emit(unexpected => $res); return unless length(my $leftovers = $res->content->leftovers); $self->client_read($leftovers); } sub client_write { shift->_write(0) } sub is_empty { !!(uc $_[0]->req->method eq 'HEAD' || $_[0]->res->is_empty) } sub keep_alive { my $self = shift; # Close my $req = $self->req; my $res = $self->res; my $req_conn = lc($req->headers->connection // ''); my $res_conn = lc($res->headers->connection // ''); return undef if $req_conn eq 'close' || $res_conn eq 'close'; # Keep-alive return 1 if $req_conn eq 'keep-alive' || $res_conn eq 'keep-alive'; # No keep-alive for 1.0 return !($req->version eq '1.0' || $res->version eq '1.0'); } sub redirects { my $previous = shift; my @redirects; unshift @redirects, $previous while $previous = $previous->previous; return \@redirects; } sub server_read { my ($self, $chunk) = @_; # Parse request my $req = $self->req; $req->parse($chunk) unless $req->error; $self->{state} ||= 'read'; # Generate response return unless $req->is_finished && !$self->{handled}++; $self->emit(upgrade => Mojo::Transaction::WebSocket->new(handshake => $self)) if lc($req->headers->upgrade // '') eq 'websocket'; $self->emit('request'); } sub server_write { shift->_write(1) } sub _body { my ($self, $msg, $finish) = @_; # Prepare body chunk my $buffer = $msg->get_body_chunk($self->{offset}); my $written = defined $buffer ? length $buffer : 0; $self->{write} = $msg->content->is_dynamic ? 1 : ($self->{write} - $written); $self->{offset} = $self->{offset} + $written; if (defined $buffer) { delete $self->{delay} } # Delayed else { if (delete $self->{delay}) { $self->{state} = 'paused' } else { $self->{delay} = 1 } } # Finished $self->{state} = $finish ? 'finished' : 'read' if $self->{write} <= 0 || (defined $buffer && !length $buffer); return defined $buffer ? $buffer : ''; } sub _headers { my ($self, $msg, $head) = @_; # Prepare header chunk my $buffer = $msg->get_header_chunk($self->{offset}); my $written = defined $buffer ? length $buffer : 0; $self->{write} = $self->{write} - $written; $self->{offset} = $self->{offset} + $written; # Switch to body if ($self->{write} <= 0) { $self->{offset} = 0; # Response without body if ($head && $self->is_empty) { $self->{state} = 'finished' } # Body else { $self->{http_state} = 'body'; $self->{write} = $msg->content->is_dynamic ? 1 : $msg->body_size; } } return $buffer; } sub _start_line { my ($self, $msg) = @_; # Prepare start line chunk my $buffer = $msg->get_start_line_chunk($self->{offset}); my $written = defined $buffer ? length $buffer : 0; $self->{write} = $self->{write} - $written; $self->{offset} = $self->{offset} + $written; # Switch to headers if ($self->{write} <= 0) { $self->{http_state} = 'headers'; $self->{write} = $msg->header_size; $self->{offset} = 0; } return $buffer; } sub _write { my ($self, $server) = @_; # Client starts writing right away $self->{state} ||= 'write' unless $server; return '' unless $self->{state} eq 'write'; # Nothing written yet $self->{$_} ||= 0 for qw(offset write); my $msg = $server ? $self->res : $self->req; unless ($self->{http_state}) { # Connection header my $headers = $msg->headers; $headers->connection($self->keep_alive ? 'keep-alive' : 'close') unless $headers->connection; # Switch to start line $self->{http_state} = 'start_line'; $self->{write} = $msg->start_line_size; } # Start line my $chunk = ''; $chunk .= $self->_start_line($msg) if $self->{http_state} eq 'start_line'; # Headers $chunk .= $self->_headers($msg, $server) if $self->{http_state} eq 'headers'; # Body $chunk .= $self->_body($msg, $server) if $self->{http_state} eq 'body'; return $chunk; } 1; =encoding utf8 =head1 NAME Mojo::Transaction::HTTP - HTTP transaction =head1 SYNOPSIS use Mojo::Transaction::HTTP; # Client my $tx = Mojo::Transaction::HTTP->new; $tx->req->method('GET'); $tx->req->url->parse('http://example.com'); $tx->req->headers->accept('application/json'); say $tx->res->code; say $tx->res->headers->content_type; say $tx->res->body; say $tx->remote_address; # Server my $tx = Mojo::Transaction::HTTP->new; say $tx->req->method; say $tx->req->url->to_abs; say $tx->req->headers->accept; say $tx->remote_address; $tx->res->code(200); $tx->res->headers->content_type('text/plain'); $tx->res->body('Hello World!'); =head1 DESCRIPTION L is a container for HTTP transactions as described in RFC 2616. =head1 EVENTS L inherits all events from L and can emit the following new ones. =head2 request $tx->on(request => sub { my $tx = shift; ... }); Emitted when a request is ready and needs to be handled. $tx->on(request => sub { my $tx = shift; $tx->res->headers->header('X-Bender' => 'Bite my shiny metal ass!'); }); =head2 unexpected $tx->on(unexpected => sub { my ($tx, $res) = @_; ... }); Emitted for unexpected C<1xx> responses that will be ignored. $tx->on(unexpected => sub { my $tx = shift; $tx->res->on(finish => sub { say 'Followup response is finished.' }); }); =head2 upgrade $tx->on(upgrade => sub { my ($tx, $ws) = @_; ... }); Emitted when transaction gets upgraded to a L object. $tx->on(upgrade => sub { my ($tx, $ws) = @_; $ws->res->headers->header('X-Bender' => 'Bite my shiny metal ass!'); }); =head1 ATTRIBUTES L inherits all attributes from L and implements the following new ones. =head2 previous my $previous = $tx->previous; $tx = $tx->previous(Mojo::Transaction->new); Previous transaction that triggered this followup transaction. # Paths of previous requests say $tx->previous->previous->req->url->path; say $tx->previous->req->url->path; =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 client_read $tx->client_read($bytes); Read data client-side, used to implement user agents. =head2 client_write my $bytes = $tx->client_write; Write data client-side, used to implement user agents. =head2 is_empty my $bool = $tx->is_empty; Check transaction for C request and C<1xx>, C<204> or C<304> response. =head2 keep_alive my $bool = $tx->keep_alive; Check if connection can be kept alive. =head2 redirects my $redirects = $tx->redirects; Return a list of all previous transactions that preceded this followup transaction. # Paths of all previous requests say $_->req->url->path for @{$tx->redirects}; =head2 server_read $tx->server_read($bytes); Read data server-side, used to implement web servers. =head2 server_write my $bytes = $tx->server_write; Write data server-side, used to implement web servers. =head1 SEE ALSO L, L, L. =cut