diff options
Diffstat (limited to 'web/server/h2o/libh2o/misc/p5-net-fastcgi/eg')
| -rwxr-xr-x | web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/runfcgi.pl | 226 | ||||
| -rwxr-xr-x | web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/server.pl | 164 |
2 files changed, 390 insertions, 0 deletions
diff --git a/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/runfcgi.pl b/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/runfcgi.pl new file mode 100755 index 00000000..7ee01a9f --- /dev/null +++ b/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/runfcgi.pl @@ -0,0 +1,226 @@ +#!/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"; + } +} diff --git a/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/server.pl b/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/server.pl new file mode 100755 index 00000000..74a8db7e --- /dev/null +++ b/web/server/h2o/libh2o/misc/p5-net-fastcgi/eg/server.pl @@ -0,0 +1,164 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use IO::Socket qw[]; +use PerlIO::scalar qw[]; +use Net::FastCGI::Constant qw[:type :role :flag :protocol_status FCGI_NULL_REQUEST_ID]; +use Net::FastCGI::IO qw[read_record write_record write_stream]; +use Net::FastCGI::Protocol qw[build_end_request_body + build_unknown_type_body + build_params + parse_begin_request_body + parse_params + dump_record_body ]; + +my %FCGI_VALUES = ( + FCGI_MAX_CONNS => 1, # maximum number of concurrent transport connections this application will accept + FCGI_MAX_REQS => 1, # maximum number of concurrent requests this application will accept + FCGI_MPXS_CONNS => 0, # multiplex +); + +sub handle_connection { + my ($socket, $on_request) = @_; + + my ( $current_id, # id of the request we are currently processing + $stdin, # buffer for stdin + $stdout, # buffer for stdout + $stderr, # buffer for stderr + $params, # buffer for params (environ) + $keep_conn ); # more requests on this connection? + + ($current_id, $stdin, $stdout, $stderr, $params) = (0, '', '', '', '', ''); + + use warnings FATAL => 'Net::FastCGI::IO'; + + while () { + my ($type, $request_id, $content) = read_record($socket) + or last; + + if ($request_id == FCGI_NULL_REQUEST_ID) { + if ($type == FCGI_GET_VALUES) { + my $values = parse_params($content); + my %params = map { $_ => $FCGI_VALUES{$_} } + grep { exists $FCGI_VALUES{$_} } + keys %{$values}; + write_record($socket, FCGI_GET_VALUES_RESULT, + FCGI_NULL_REQUEST_ID, build_params(\%params)); + } + else { + write_record($socket, FCGI_UNKNOWN_TYPE, + FCGI_NULL_REQUEST_ID, build_unknown_type_body($type)); + } + } + elsif ($type == FCGI_BEGIN_REQUEST) { + my ($role, $flags) = parse_begin_request_body($content); + if ($current_id || $role != FCGI_RESPONDER) { + my $status = $current_id ? FCGI_CANT_MPX_CONN : FCGI_UNKNOWN_ROLE; + write_record($socket, FCGI_END_REQUEST, $request_id, + build_end_request_body(0, $status)); + } + else { + $current_id = $request_id; + $keep_conn = ($flags & FCGI_KEEP_CONN); + } + } + elsif ($request_id != $current_id) { + # ignore inactive requests (FastCGI Specification 3.3) + } + elsif ($type == FCGI_ABORT_REQUEST) { + $current_id = 0; + ($stdin, $stdout, $stderr, $params) = ('', '', '', ''); + } + elsif ($type == FCGI_PARAMS) { + $params .= $content; + } + elsif ($type == FCGI_STDIN) { + $stdin .= $content; + + unless (length $content) { + # process request + + open(my $in, '<', \$stdin) + || die(qq/Couldn't open scalar as a file handle: $!/); + + open(my $out, '>', \$stdout) + || die(qq/Couldn't open scalar as a file handle: $!/); + + open(my $err, '>', \$stderr) + || die(qq/Couldn't open scalar as a file handle: $!/); + + my $environ = parse_params($params); + + eval { + $on_request->($environ, $in, $out, $err); + }; + + if (my $e = $@) { + warn(qq/Caught an exception in request callback: '$e'/); + $stdout = "Status: 500 Internal Server Error\n\n"; + } + + write_stream($socket, FCGI_STDOUT, $current_id, $stdout, 1); + write_stream($socket, FCGI_STDERR, $current_id, $stderr, 1) + if length $stderr; + write_record($socket, FCGI_END_REQUEST, $current_id, + build_end_request_body(0, FCGI_REQUEST_COMPLETE)); + + # prepare for next request + $current_id = 0; + ($stdin, $stdout, $stderr, $params) = ('', '', '', ''); + + last unless $keep_conn; + } + } + else { + warn(q/Received an unexpected record: / . + dump_record_body($type, $request_id, $content)); + } + } + + (!$current_id) + || warn(q/Client prematurely closed connection/); +} + +sub handle_request { + my ($env, $stdin, $stdout, $stderr) = @_; + + $env->{GATEWAY_INTERFACE} ||= 'CGI/1.1'; + + local *ENV = $env; + local *STDIN = $stdin; + local *STDOUT = $stdout; + local *STDERR = $stderr; + + print "Status: 200 OK\n"; + print "Content-Type: text/plain\n\n"; + print map { sprintf "%-25s => %s\n", $_, $ENV{$_} } sort keys %ENV; +} + +my $addr = shift(@ARGV) || 'localhost:3000'; + +my $socket = IO::Socket::INET->new( + Listen => 5, + LocalAddr => $addr, + Reuse => 1, +) or die(qq/Couldn't create INET listener socket <$addr>: '$!'./); + +print STDERR "Listening for connections on <$addr>\n"; + +while () { + my $connection = $socket->accept + or last; + + eval { + handle_connection($connection, \&handle_request); + }; + + if (my $e = $@) { + warn(qq/Caught an exception in handle_connection(): '$e'/); + } + + close $connection; +} + |