view release on metacpan or  search on metacpan

lib/Net/Async/HTTP/Server/PSGI.pm  view on Meta::CPAN

#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2013-2024 -- leonerd@leonerd.org.uk

package Net::Async::HTTP::Server::PSGI 0.15;

use v5.14;
use warnings;

use Carp;

use base qw( Net::Async::HTTP::Server );

use HTTP::Response;

my $CRLF = "\x0d\x0a";

=head1 NAME

C<Net::Async::HTTP::Server::PSGI> - use C<PSGI> applications with C<Net::Async::HTTP::Server>

=head1 SYNOPSIS

   use Net::Async::HTTP::Server::PSGI;
   use IO::Async::Loop;

   my $loop = IO::Async::Loop->new;

   my $httpserver = Net::Async::HTTP::Server::PSGI->new(
      app => sub {
         my $env = shift;

         return [
            200,
            [ "Content-Type" => "text/plain" ],
            [ "Hello, world!" ],
         ];
      },
   );

   $loop->add( $httpserver );

   $httpserver->listen(
      addr => { family => "inet6", socktype => "stream", port => 8080 },
   )->get;

   $loop->run;

=head1 DESCRIPTION

This subclass of L<Net::Async::HTTP::Server> allows an HTTP server to use a
L<PSGI> application to respond to requests. It acts as a gateway between the
HTTP connection from the web client, and the C<PSGI> application. Aside from
the use of C<PSGI> instead of the C<on_request> event, this class behaves
similarly to C<Net::Async::HTTP::Server>.

To handle the content length when sending responses, the PSGI implementation
may add a header to the response. When sending a plain C<ARRAY> of strings, if
a C<Content-Length> header is absent, the length will be calculated by taking
the total of all the strings in the array, and setting the length header. When
sending content from an IO reference or using the streaming responder C<CODE>
reference, the C<Transfer-Encoding> header will be set to C<chunked>, and all
writes will be performed as C<HTTP/1.1> chunks.

=cut

=head1 PARAMETERS

The following named parameters may be passed to C<new> or C<configure>:

=over 8

=item app => CODE

Reference to the actual C<PSGI> application to use for responding to requests

=back

=cut

sub configure
{
   my $self = shift;
   my %args = @_;

   if( exists $args{app} ) {
      $self->{app} = delete $args{app};
   }

   $self->SUPER::configure( %args );
}

=head1 PSGI ENVIRONMENT

The following extra keys are supplied to the environment of the C<PSGI> app:

=over 8

=item C<psgix.io>

The actual L<IO::Socket> filehandle that the request was received on.

If the server is running under SSL for HTTPS, this will be an
L<IO::Socket::SSL> instance, so reading from or writing to it will happen in
cleartext.

=item C<net.async.http.server>

The C<Net::Async::HTTP::Server::PSGI> object serving the request

=item C<net.async.http.server.req>

The L<Net::Async::HTTP::Server::Request> object representing this particular
request

=item C<io.async.loop>

The L<IO::Async::Loop> object that the C<Net::Async::HTTP::Server::PSGI>
object is a member of.

=back

=cut

sub on_request
{
   my $self = shift;
   my ( $req ) = @_;

   # Much of this code stolen fro^W^Winspired by Plack::Handler::Net::FastCGI

   open my $stdin, "<", \$req->body;

   my $socket = $req->stream->read_handle;

   my $path_info = $req->path;
   $path_info = "" if $path_info eq "/";

   my %env = (
      SERVER_PROTOCOL     => $req->protocol,
      SCRIPT_NAME         => '',
      PATH_INFO           => $path_info,
      QUERY_STRING        => $req->query_string // "",
      REQUEST_METHOD      => $req->method,
      REQUEST_URI         => $req->path,
      'psgi.version'      => [1,0],
      'psgi.url_scheme'   => "http",
      'psgi.input'        => $stdin,
      'psgi.errors'       => \*STDERR,
      'psgi.multithread'  => 0,
      'psgi.multiprocess' => 0,
      'psgi.run_once'     => 0,
      'psgi.nonblocking'  => 1,
      'psgi.streaming'    => 1,

      # Extensions
      'psgix.io'                  => $socket,
      'psgix.input.buffered'      => 1, # we're using a PerlIO scalar handle
      'net.async.http.server'     => $self,
      'net.async.http.server.req' => $req,
      'io.async.loop'             => $self->get_loop,
   );

   if( $socket->can( "sockport" ) ) { # INET or IP
      %env = ( %env,
         SERVER_PORT => $socket->sockport,
         SERVER_NAME => $socket->sockhost,
         REMOTE_ADDR => $socket->peerhost,
         REMOTE_PORT => $socket->peerport,
      );
   }
   elsif( $socket->can( "hostpath" ) ) { # UNIX
      %env = ( %env,
         SERVER_PORT => $socket->hostpath,
         SERVER_NAME => "localhost",  # not really but we can lie
         # no REMOTE_*
      );
   }

   foreach ( $req->headers ) {
      my ( $name, $value ) = @$_;
      $name =~ s/-/_/g;
      $name = uc $name;

      # Content-Length and Content-Type don't get HTTP_ prefix
      $name = "HTTP_$name" unless $name =~ m/^CONTENT_(?:LENGTH|TYPE)$/;

      $env{$name} = $value;
   }

   my $resp = $self->{app}->( \%env );

   my $responder = sub {
      my ( $status, $headers, $body ) = @{ +shift };

      my $response = HTTP::Response->new( $status );
      $response->protocol( $req->protocol );

      my $has_content_length = 0;
      my $use_chunked_transfer;
      while( my ( $key, $value ) = splice @$headers, 0, 2 ) {
         $response->push_header( $key, $value );

         $has_content_length = 1 if $key eq "Content-Length";
         $use_chunked_transfer++ if $key eq "Transfer-Encoding" and $value eq "chunked";
      }

      if( !defined $body ) {
         croak "Responder given no body in void context" unless defined wantarray;

         unless( $has_content_length ) {
            $response->header( "Transfer-Encoding" => "chunked" );
            $use_chunked_transfer++;
         }