File Coverage

blib/lib/Mojo/Server/FastCGI.pm

Criterion	Covered	Total	%
statement	12	163	7.3
branch	0	86	0.0
condition	1	33	3.0
subroutine	4	16	25.0
pod	10	10	100.0
total	27	308	8.7

package Mojo::Server::FastCGI;
use Mojo::Base 'Mojo::Server';

use Errno qw/EAGAIN EINTR EWOULDBLOCK/;
use IO::Socket;

use constant DEBUG => $ENV{MOJO_FASTCGI_DEBUG} || 0;

our $VERSION = '0.41';

# Roles
my @ROLES = qw/RESPONDER  AUTHORIZER FILTER/;
my %ROLE_NUMBERS;
{
  my $i = 1;
  for my $role (@ROLES) {
    $ROLE_NUMBERS{$role} = $i;
    $i++;
  }
}

# Types
my @TYPES = qw/
  BEGIN_REQUEST
  ABORT_REQUEST
  END_REQUEST
  PARAMS
  STDIN
  STDOUT
  STDERR
  DATA
  GET_VALUES
  GET_VALUES_RESULT
  UNKNOWN_TYPE
  /;
my %TYPE_NUMBERS;
{
  my $i = 1;
  for my $type (@TYPES) {
    $TYPE_NUMBERS{$type} = $i;
    $i++;
  }
}

# "Wow! Homer must have got one of those robot cars!
#  *Car crashes in background*
#  Yeah, one of those AMERICAN robot cars."
sub accept_connection {
  my $self = shift;

  # Listen socket
  unless ($self->{listen}) {
    my $listen = IO::Socket->new;

    # Open
    unless ($listen->fdopen(0, 'r')) {
      $self->app->log->error("Can't open FastCGI socket fd0: $!");
      return;
    }

    $self->{listen} = $listen;
  }
  $self->app->log->debug('FastCGI listen socket opened.') if DEBUG;

  # Accept
  my $c;
  unless ($c = $self->{listen}->accept) {
    $self->app->log->error("Can't accept FastCGI connection: $!");
    return;
  }
  $self->app->log->debug('Accepted FastCGI connection.') if DEBUG;

  return $c;
}

sub read_record {
  my ($self, $c) = @_;
  return unless $c;

  # Header
  my $header = $self->_read_chunk($c, 8);
  return unless $header;
  my ($version, $type, $id, $clen, $plen) = unpack 'CCnnC', $header;

  # Body
  my $body = $self->_read_chunk($c, $clen + $plen);

  # No content, just paddign bytes
  $body = undef unless $clen;

  # Ignore padding bytes
  $body = $plen ? substr($body, 0, $clen, '') : $body;

  if (DEBUG) {
    my $t = $self->type_name($type);
    $self->app->log->debug(
      qq/Reading FastCGI record: $type - $id - "$body"./);
  }

  return $self->type_name($type), $id, $body;
}

sub read_request {
  my ($self, $c) = @_;
  $self->app->log->debug('Reading FastCGI request.') if DEBUG;

  # Transaction
  my $tx =
      $self->can('build_tx')
    ? $self->build_tx
    : $self->on_transaction->($self);
  $tx->connection($c);
  my $req = $tx->req;

  # Type
  my ($type, $id, $body) = $self->read_record($c);
  unless ($type && $type eq 'BEGIN_REQUEST') {
    $self->app->log->info("First FastCGI record wasn't a begin request.");
    return;
  }
  $ENV{FCGI_ID} = $tx->{fcgi_id} = $id;

  # Role/Flags
  my ($role, $flags) = unpack 'nC', $body;
  $ENV{FCGI_ROLE} = $tx->{fcgi_role} = $self->role_name($role);

  # Slurp
  my $buffer = '';
  my $env    = {};
  while (($type, $id, $body) = $self->read_record($c)) {

    # Wrong id
    next unless $id == $tx->{fcgi_id};

    # Params
    if ($type eq 'PARAMS') {

      # Normal param chunk
      if ($body) {
        $buffer .= $body;
        next;
      }

      # Params done
      while (length $buffer) {

        # Name and value length
        my $name_len  = $self->_nv_length(\$buffer);
        my $value_len = $self->_nv_length(\$buffer);

        # Name and value
        my $name  = substr $buffer, 0, $name_len,  '';
        my $value = substr $buffer, 0, $value_len, '';

        # Environment
        $env->{$name} = $value;
        $self->app->log->debug(qq/FastCGI param: $name - "$value"./)
          if DEBUG;

        # Store connection information
        $tx->remote_address($value) if $name =~ /REMOTE_ADDR/i;
        $tx->local_port($value)     if $name =~ /SERVER_PORT/i;
      }
    }

    # Stdin
    elsif ($type eq 'STDIN') {

      # Environment
      if (keys %$env) {
        $req->parse($env);
        $env = {};
      }

      # EOF
      last unless $body;

      # Chunk
      $req->parse($body);

      # Error
      return $tx if $req->error;
    }
  }

  return $tx;
}

sub role_name {
  my ($self, $role) = @_;
  return unless $role;
  return $ROLES[$role - 1];
}

sub role_number {
  my ($self, $role) = @_;
  return unless $role;
  return $ROLE_NUMBERS{uc $role};
}

sub run {
  my $self = shift;

  # Preload application
  $self->app;

  # New incoming request
  while (my $c = $self->accept_connection) {

    # Request
    my $tx = $self->read_request($c);

    # Error
    unless ($tx) {
      $self->app->log->info("No transaction for FastCGI request.");
      next;
    }

    # Handle
    $self->app->log->debug('Handling FastCGI request.') if DEBUG;
    $self->can('emit')
      ? $self->emit(request => $tx)
      : $self->on_request->($self, $tx);

    # Response
    $self->write_response($tx);

    # Finish transaction
    $tx->server_close;
  }
}

sub type_name {
  my ($self, $type) = @_;
  return unless $type;
  return $TYPES[$type - 1];
}

sub type_number {
  my ($self, $type) = @_;
  return unless $type;
  return $TYPE_NUMBERS{uc $type};
}

sub write_records {
  my ($self, $c, $type, $id, $body) = @_;
  return unless defined $c && defined $type && defined $id;
  $body //= '';

  # Write records
  my $empty    = $body ? 0 : 1;
  my $offset   = 0;
  my $body_len = length $body;
  while (($body_len > 0) || $empty) {

    # Need to split content
    my $payload_len = $body_len > 32 * 1024 ? 32 * 1024 : $body_len;
    my $pad_len = (8 - ($payload_len % 8)) % 8;

    # FCGI version 1 record
    my $template = "CCnnCxa${payload_len}x$pad_len";

    if (DEBUG) {
      my $chunk = substr($body, $offset, $payload_len);
      $self->app->log->debug(
        qq/Writing FastCGI record: $type - $id - "$chunk"./);
    }

    # Write whole record
    my $record = pack $template, 1, $self->type_number($type), $id,
      $payload_len,
      $pad_len,
      substr($body, $offset, $payload_len);
    my $woffset = 0;
    while ($woffset < length $record) {
      my $written = $c->syswrite($record, undef, $woffset);

      # Error
      unless (defined $written) {

        # Retry
        next if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;

        # Write error
        return;
      }

      $woffset += $written;
    }
    $body_len -= $payload_len;
    $offset += $payload_len;

    # Done
    last if $empty;
  }

  return 1;
}

sub write_response {
  my ($self, $tx) = @_;
  $self->app->log->debug('Writing FastCGI response.') if DEBUG;

  # Status
  my $res     = $tx->res;
  my $code    = $res->code || 404;
  my $message = $res->message || $res->default_message;
  $res->headers->status("$code $message") unless $res->headers->status;

  # Fix headers
  $res->fix_headers;

  # Headers
  my $c      = $tx->connection;
  my $offset = 0;
  while (1) {
    my $chunk = $res->get_header_chunk($offset);

    # No headers yet, try again
    unless (defined $chunk) {
      sleep 1;
      next;
    }

    # End of headers
    last unless length $chunk;

    # Headers
    $offset += length $chunk;
    return
      unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, $chunk);
  }

  # Body
  $offset = 0;
  while (1) {
    my $chunk = $res->get_body_chunk($offset);

    # No content yet, try again
    unless (defined $chunk) {
      sleep 1;
      next;
    }

    # End of content
    last unless length $chunk;

    # Content
    $offset += length $chunk;
    return
      unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, $chunk);
  }

  # The end
  return
    unless $self->write_records($c, 'STDOUT', $tx->{fcgi_id}, undef);
  return
    unless $self->write_records($c, 'END_REQUEST', $tx->{fcgi_id},
    pack('CCCCCCCC', 0));
}

sub _nv_length {
  my ($self, $bodyref) = @_;

  # Try first byte
  my $len = unpack 'C', substr($$bodyref, 0, 1, '');

  # 4 byte length
  if ($len & 0x80) {
    $len = pack 'C', $len & 0x7F;
    substr $len, 1, 0, substr($$bodyref, 0, 3, '');
    $len = unpack 'N', $len;
  }

  return $len;
}

sub _read_chunk {
  my ($self, $c, $len) = @_;

  # Read
  my $chunk = '';
  while (length $chunk < $len) {
    my $read = $c->sysread(my $buffer, $len - length $chunk, 0);
    unless (defined $read) {
      next if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;
      last;
    }
    last unless $read;
    $chunk .= $buffer;
  }

  return $chunk;
}

1;
__END__