lib/Catalyst/Engine/SCGI.pm

   1 package Catalyst::Engine::SCGI;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI';
   5 eval "use SCGI";
   6 die "Please install SCGI\n" if $@;
   7 use IO::Socket;
   8 use Data::Dumper;
   9
  10
  11 my $uri_proto=URI->new();
  12
  13 =head1 NAME
  14
  15 Catalyst::Engine::SCGI - SCGI Engine
  16
  17 =head1 DESCRIPTION
  18
  19 This is the SCGI engine.
  20
  21 =head1 OVERLOADED METHODS
  22
  23 This class overloads some methods from C<Catalyst::Engine::CGI>.
  24
  25 =head2 $self->run($c, $port, $detach)
  26
  27 Start the SCGI server.  If $port is not set default to port 9000. If $detach is set, server will go into the background.
  28
  29 =cut
  30
  31 sub run {
  32     my ( $self, $class, $port, $detach ) = @_;
  33
  34     my $sock = 0;
  35     $port = 9000 unless defined $port;
  36     my $socket = IO::Socket::INET->new(
  37         Listen    => 5,
  38         ReuseAddr => 1,
  39         LocalPort => $port,
  40     ) or die "cannot bind to port $port: $!";
  41     $sock = SCGI->new( $socket, blocking => 1 )
  42       or die "Failed to open SCGI socket; $!";
  43
  44     $self->daemon_fork()   if defined $detach;
  45     $self->daemon_detach() if defined $detach;
  46     while ( my $request = $sock->accept ) {
  47         eval { $request->read_env };
  48         if ($@) {
  49
  50             # some error
  51         }
  52         else {
  53             $self->{_request} = $request;
  54             $class->handle_request( env => $request->env );
  55             # make sure to close once we are done.
  56             $request->close();
  57         }
  58     }
  59 }
  60
  61 =head2 $self->finalize_headers ( $c )
  62
  63  Write finalized headers to socket
  64
  65 =cut
  66 sub finalize_headers {
  67     my ( $self, $c ) = @_;
  68     $c->response->header( Status => $c->response->status );
  69     $self->{_request}->connection->print(
  70         $c->response->headers->as_string("\015\012") . "\015\012" );
  71 }
  72
  73 =head2 $self->write ( $c, $buffer )
  74
  75  Write directly to socket
  76
  77 =cut
  78 sub write {
  79     my ( $self, $c, $buffer ) = @_;
  80
  81     unless ( $self->{_prepared_write} ) {
  82         $self->prepare_write($c);
  83         $self->{_prepared_write} = 1;
  84     }
  85
  86     $self->{_request}->connection->print($buffer);
  87 }
  88
  89 =head2 $self->prepare_path($c)
  90
  91 =cut
  92 sub prepare_path {
  93     my ( $self, $c ) = @_;
  94     local (*ENV) = $self->env || \%ENV;
  95
  96     my $scheme = $c->request->secure ? 'https' : 'http';
  97     my $host      = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME};
  98     my $port      = $ENV{SERVER_PORT} || 80;
  99     my $base_path;
 100     if ( exists $ENV{REDIRECT_URL} ) {
 101         $base_path = $ENV{REDIRECT_URL};
 102         $base_path =~ s/$ENV{PATH_INFO}$//;
 103     }
 104     else {
 105         $base_path = $ENV{SCRIPT_NAME} || '/';
 106     }
 107
 108     # If we are running as a backend proxy, get the true hostname
 109   PROXY_CHECK:
 110     {
 111         unless ( $c->config->{using_frontend_proxy} ) {
 112             last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
 113             last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
 114         }
 115         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
 116
 117         $host = $ENV{HTTP_X_FORWARDED_HOST};
 118
 119         # backend could be on any port, so
 120         # assume frontend is on the default port
 121         $port = $c->request->secure ? 443 : 80;
 122     }
 123
 124     my $path = $base_path . ( $ENV{PATH_INFO} || '' );
 125     $path =~ s{^/+}{};
 126
 127     my $uri = $uri_proto->clone;
 128     $uri->scheme($scheme);
 129     $uri->host($host);
 130     $uri->port($port);
 131     $uri->path($path);
 132     $uri->query( $ENV{QUERY_STRING} ) if $ENV{QUERY_STRING};
 133
 134     # sanitize the URI
 135     $uri = $uri->canonical;
 136     $c->request->uri($uri);
 137
 138     # set the base URI
 139     # base must end in a slash
 140     $base_path .= '/' unless ( $base_path =~ /\/$/ );
 141     my $base = $uri->clone;
 142
 143     my ($base_uri) = $base_path=~ /(.*?)\//;
 144     $base_uri .= '/' unless ($base_uri =~/\/$/ );
 145
 146     $base->path_query($base_uri);
 147     $c->request->base($base);
 148 }
 149
 150 =head2 $self->read_chunk ( $c, $buffer, $readlen )
 151
 152  Read Body content to $_[3]'s set length and direct output to $_[2].
 153
 154 =cut
 155 sub read_chunk {
 156     my ( $self, $c ) = @_;
 157     my $rc = read( $self->{_request}->connection, $_[2], $_[3] );
 158     return $rc;
 159 }
 160
 161 =head2 $self->daemon_fork()
 162
 163 Performs the first part of daemon initialisation.  Specifically,
 164 forking.  STDERR, etc are still connected to a terminal.
 165
 166 =cut
 167
 168 sub daemon_fork {
 169     require POSIX;
 170     fork && exit;
 171 }
 172
 173 =head2 $self->daemon_detach( )
 174
 175 Performs the second part of daemon initialisation.  Specifically,
 176 disassociates from the terminal.
 177
 178 However, this does B<not> change the current working directory to "/",
 179 as normal daemons do.  It also does not close all open file
 180 descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
 181 F</dev/null>).
 182
 183 =cut
 184
 185 sub daemon_detach {
 186     my $self = shift;
 187     print "SCGI daemon started (pid $$)\n";
 188     open STDIN,  "+</dev/null" or die $!;
 189     open STDOUT, ">&STDIN"     or die $!;
 190     open STDERR, ">&STDIN"     or die $!;
 191     POSIX::setsid();
 192 }
 193
 194 1;