#!/usr/bin/perl
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk
use strict;
use warnings;
use Getopt::Long;
use Net::FastCGI::IO qw( read_record );
use Net::FastCGI::Constant qw( :common :type :role );
use Net::FastCGI::Protocol qw(
build_begin_request_body
build_params
parse_end_request_body
);
sub write_record
{
Net::FastCGI::IO::write_record(@_) or
die "Cannot write_record - $!";
}
my %env = (
REQUEST_METHOD => "GET",
SCRIPT_NAME => "",
SERVER_NAME => "server",
SERVER_PORT => 80,
SERVER_PROTOCOL => "HTTP/1.1",
);
my $stdin_from;
my $filter_stdout;
sub usage
{
print <<"EOF";
$0 [options] CONNECT URL
Runs the FastCGI found at CONNECT, as if it had received the URL
CONNECT may be any of
exec:PATH Execute as a child process with socket on STDIN
unix:PATH Find a UNIX socket on the given path
tcp:HOST:PORT Connect to the given port on the given host
HOST:PORT as above
options may be:
--body Print just the HTTP response body
--no-body Print just the HTTP response headers without the body
-m, --method METHOD Use the specified method (default "GET")
-p, --post Method is POST, pass STDIN
--put Method is PUT, pass STDIN
--stdin PATH Read STDIN from specified path, "-" means real script
EOF
}
GetOptions(
'body' => sub {
defined $filter_stdout and die "Cannot --no-body and --body\n";
$filter_stdout = "body";
},
'no-body' => sub {
defined $filter_stdout and die "Cannot --no-body and --body\n";
$filter_stdout = "headers";
},
'm|method=s' => \$env{REQUEST_METHOD},
'p|post' => sub {
$env{REQUEST_METHOD} = "POST";
$stdin_from = "-";
},
'put' => sub {
$env{REQUEST_METHOD} = "PUT";
$stdin_from = "-";
},
'stdin=s' => \$stdin_from,
'help' => sub { usage; exit(0) },
) or exit(1);
my $connect = shift @ARGV or
die "Require connection string\n";
my $url = shift @ARGV or
die "Require a URL";
if( $url =~ s{^http(s?)://([^/:]+)(?::([^/]+))?}{} ) {
$env{HTTPS} = "on" if $1;
$env{SERVER_NAME} = $2;
$env{SERVER_PORT} = $3 || ( $1 ? 443 : 80 );
}
$env{REQUEST_URI} = $url;
my ( $path, $query ) = $url =~ m/^(.*)(?:\?(.*))$/;
$env{PATH_INFO} = $path;
$env{QUERY_STRING} = $query;
my $socket;
if( $connect =~ m/^unix:(.*)$/ ) {
my $path = $1;
require IO::Socket::UNIX;
$socket = IO::Socket::UNIX->new(
Peer => $path,
) or die "Cannot connect - $!\n";
}
elsif( $connect =~ m/^exec:(.*)$/ ) {
my $script = $1;
require IO::Socket::INET;
my $listener = IO::Socket::INET->new(
LocalHost => "localhost",
Listen => 1,
) or die "Cannot listen - $@";
defined( my $kid = fork ) or die "Cannot fork - $!";
END { defined $kid and kill TERM => $kid }
if( $kid == 0 ) {
close STDIN;
open STDIN, "<&", $listener or die "Cannot dup $listener to STDIN - $!";
close $listener;
exec { $script } $script or die "Cannot exec $script - $!";
}
$socket = IO::Socket::INET->new(
PeerHost => $listener->sockhost,
PeerPort => $listener->sockport,
) or die "Cannot connect - $@";
close $listener;
}
elsif( $connect =~ m/^(?:tcp:)?(.*):(.+?)$/ ) {
my $host = $1 || "localhost";
my $port = $2;
my $class = eval { require IO::Socket::IP and "IO::Socket::IP" } ||
do { require IO::Socket::INET and "IO::Socket::INET" };
$socket = $class->new(
PeerHost => $host,
PeerPort => $port,
) or die "Cannot connect - $@\n";
}
else {
die "Cannot recognise connection string '$connect'\n";
}
write_record( $socket, FCGI_BEGIN_REQUEST, 1,
build_begin_request_body( FCGI_RESPONDER, 0 ) );
write_record( $socket, FCGI_PARAMS, 1,
build_params( \%env ) );
write_record( $socket, FCGI_PARAMS, 1, "" );
if( defined $stdin_from ) {
my $stdin;
if( $stdin_from eq "-" ) {
$stdin = \*STDIN;
}
else {
open $stdin, "<", $stdin_from or die "Cannot open $stdin_from for input - $!";
}
while( read( $stdin, my $buffer, 8192 ) ) {
write_record( $socket, FCGI_STDIN, 1, $buffer );
}
}
write_record( $socket, FCGI_STDIN, 1, "" );
my $stdout = "";
while(1) {
my ( $type, $id, $content ) = read_record( $socket )
or $! and die "Cannot read_record - $!"
or last;
if( $type == FCGI_STDOUT ) {
if( !defined $filter_stdout ) {
print STDOUT $content;
}
elsif( $filter_stdout eq "headers" ) {
my $oldlen = length $stdout;
$stdout .= $content;
if( $stdout =~ m/\r\n\r\n/ ) {
# Print only the bit we haven't done yet
print STDOUT substr( $stdout, $oldlen, $+[0] - $oldlen );
$filter_stdout = 1; # I.e. suppress the lot
}
else {
print STDOUT $content;
}
}
elsif( $filter_stdout eq "body" ) {
$stdout .= $content;
if( $stdout =~ m/\r\n\r\n/ ) {
print STDOUT substr( $stdout, $+[0] );
$filter_stdout = undef;
}
}
}
elsif( $type == FCGI_STDERR ) {
print STDERR $content;
}
elsif( $type == FCGI_END_REQUEST ) {
my ( $app_status, $protocol_status ) = parse_end_request_body( $content );
exit $app_status;
}
else {
die "Unrecognised FastCGI request type $type\n";
}
}