view release on metacpan or  search on metacpan

lib/Conduit/Client.pm  view on Meta::CPAN

   while( defined( my $req = await $self->read_request ) ) {
      my $resp;
      try {
         $resp = await $responder->( $req );
      }
      catch( $e ) {
         chomp $e;
         $resp = HTTP::Response->new( 500, undef,
            [ "Content-Type" => "text/plain" ],
            $e,
         );
      }
      $resp->request( $req );

      $resp->protocol or $resp->protocol( $req->protocol );
      $resp->content_length or $resp->content_length( length $resp->content );

      $bytes_written = 0;

      $server->on_response_header( $req, $resp )
         if $server->can( "on_response_header" );

      await $self->write( $resp->as_string( "\x0D\x0A" ) );
      Conduit::Metrics->sent_response( $resp, $bytes_written );
   }
}

class Conduit::Client::_ForPSGI
   :strict(params);
inherit Conduit::Client qw( $server $bytes_written );

no if $^V lt v5.40, warnings => "experimental::try", "experimental::builtin";

field $psgi_app :param;

async method run ()
{
   while( defined( my $req = await $self->read_request ) ) {
      my $uri = $req->uri;

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

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

      my %env = (
         SERVER_PROTOCOL     => $req->protocol,
         SCRIPT_NAME         => '',
         PATH_INFO           => $path_info,
         QUERY_STRING        => $uri->query // "",
         REQUEST_METHOD      => $req->method,
         REQUEST_URI         => $uri->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,
      );

      # TODO: socket info

      $req->scan( sub ( $name, $value ) {
         $name =~ s/-/_/g;
         $name = uc $name;

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

         $env{$name} = $value;
      } );

      my $psgiresp;
      try {
         $psgiresp = $psgi_app->( \%env );
      }
      catch( $e ) {
         chomp $e;
         $psgiresp = [ 500, [ "Content-Type" => "text/plain" ], [ $e ] ];
      }

      $bytes_written = 0;

      my $aresponder = async sub ( $v ) {
         my ( $status, $headers, $body ) = @$v;

         my $resp = HTTP::Response->new( $status );

         $resp->request( $req );
         $resp->protocol( $req->protocol );

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

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

         if( !defined $body ) {
            die "TODO: no body yet; use deferred writer";
         }
         elsif( ref $body eq "ARRAY" ) {
            unless( $has_content_length ) {
               my $len = 0;
               $len += length( $_ ) for @$body;

               $resp->content_length( $len );
            }

            $server->on_response_header( $req, $resp )
               if $server->can( "on_response_header" );

            await $self->write( $resp->as_string( "\x0D\x0A" ) );

            foreach my $chunk ( @$body ) {
               await $self->write( $chunk );