├── .gitignore ├── Changes ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── lib ├── Plack │ └── Handler │ │ └── Starlet.pm ├── Starlet.pm └── Starlet │ └── Server.pm └── t ├── 00base-hello.psgi ├── 00base.t ├── 01plack-test.t ├── 02graceful.t ├── 03post.t ├── 04-bumpy-life.t ├── 05server-header.t ├── 06harakiri.t ├── 07remote_port.t ├── 08chunked_req.t ├── 09chunked_zero_length.t ├── 10unix_domain_socket.t ├── 11multi-sockets.t ├── 12bad_request_line.t ├── 13expect.t ├── 13spawn_interval.t ├── 14child_finish_hook.t ├── 14interim_response.t ├── 15smuggling-content-length-and-transfer-encoding.t ├── 16smuggling-multiple-content-length-header.t └── assets └── baybridge.jpg /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.bak 3 | Makefile 4 | blib/ 5 | inc/ 6 | MANIFEST 7 | META.yml 8 | MYMETA.yml 9 | MYMETA.json 10 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Starlet 2 | 3 | 0.31 4 | - send 100-continue immediately #25 (Gregory Oschwald) 5 | - expose new callback for sending informational responses #29 (Kazuho Oku) 6 | 7 | 0.30 8 | - add child_exit hook #26 (by azrle) 9 | 10 | 0.29 11 | - fix workers being killed too aggressively when spawn-interval is used #27 (by limitusus) 12 | 13 | 0.28 14 | - always shutdown after SIGTERM, but only after notifying the client (via connection: close or equiv.) #23 15 | 16 | 0.26 17 | - fix abrupt connection close when receiving SIGTERM #21 (by shogo82148) 18 | 19 | 0.25 20 | - support listing to unix socket wo. using Server::Starter 21 | - suppress warning when receiving broken requests 22 | - fix test issue with Plack >= 1.0035 23 | 24 | 0.24 25 | - worker processes always receive different sequence of values when calling "rand()" 26 | 27 | 0.23 28 | - serialize calls to select -> accept when listening to multiple ports 29 | 30 | 0.22 31 | - listen to multiple ports passed from Server::Starter (ttakezawa) 32 | 33 | 0.21 34 | - support listening to unix socket (passed by Server::Starter) (kazeburo) 35 | 36 | 0.20 37 | - support HTTP/1.1 (kazeburo) 38 | 39 | 0.19 40 | - update the dependencies now that Plack no more depends on LWP (miyagawa; https://github.com/plack/Plack/pull/408) 41 | - add support for psgix.harakiri (audreyt) 42 | 43 | 0.18 44 | - change threshold for combining headers and body from 1024 bytes to 8192 45 | 46 | 0.17_01 47 | - reduce rt_sig* syscalls (kazeburo) 48 | 49 | 0.16 50 | - Set REMOTE_PORT environment variable (kazeburo) 51 | 52 | 0.15 53 | - unbundle Plack::Standalone::Server::Prefork::Server::Starter (see `perldoc Starlet` to find out how to boot Starlet using Server::Starter) 54 | 55 | 0.14 56 | - support for randomized reqs-per-child 57 | - support for slow restart 58 | - do not send Server header more than once per every response 59 | 60 | 0.13 61 | - test compatibilty improvement: ignore proxy setting while running tests (datamuc) 62 | 63 | 0.12 64 | - [bugfix] fix infinite loop when connection is closed while receiving response content (thanks to Jiro Nishiguchi-san) 65 | 66 | 0.11 67 | - suppress the warning "Use of "goto" to jump into a construct is deprecated" 68 | 69 | 0.10 70 | - switch from alarm-based polling to select-based 71 | - use TCP_DEFER_ACCEPT on linux 72 | - performance tweaks 73 | 74 | 0.09 75 | - [bugfix] enable keepalive when --max-keepalive-reqs=n (n>1) is set 76 | - accept --max-workers=n option (for better interoperability w. Starman) 77 | 78 | 0.08 79 | - [bugfix] delay termination (when receiving first SIGTERM or SIGINT) until all HTTP requests are being processed 80 | 81 | 0.07 82 | - hardcode set $PSSPSS::VERSION 83 | 84 | 0.06 85 | - set $PSSPSS::VERSION to $Starlet::VERSION 86 | 87 | 0.05 88 | - rename to Starlet from Plack::Server::Standalone::Prefork::Server::Starter (is backwards compatible) 89 | - no more depends on HTTP::Server::PSGI 90 | 91 | 0.04 92 | - follow the changes up to Plack 0.9920 93 | 94 | 0.03 95 | - try to find start_server from $PATH and $^X, or skip most tests (but not all) if not found 96 | - require 5.008, recommend HTTP::Parser::XS 97 | 98 | 0.02 99 | - require Parallel::Prefork (since Plack intentionally does not require P::Prefork required by Standalone::Prefork) 100 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \bRCS\b 2 | \bCVS\b 3 | ^MANIFEST\. 4 | ^Makefile$ 5 | ^MYMETA\. 6 | ~$ 7 | ^# 8 | \.old$ 9 | ^blib/ 10 | ^pm_to_blib 11 | ^MakeMaker-\d 12 | \.gz$ 13 | \.cvsignore 14 | ^t/9\d_.*\.t 15 | ^t/perlcritic 16 | ^tools/ 17 | \.svn/ 18 | ^[^/]+\.yaml$ 19 | ^[^/]+\.pl$ 20 | ^\.shipit$ 21 | \.git$ 22 | \.git/ 23 | nytprof/ 24 | \.rej$ 25 | \.orig$ 26 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | 3 | all_from 'lib/Starlet.pm'; 4 | readme_from 'lib/Starlet.pm'; 5 | 6 | resources repository => 'https://github.com/kazuho/Starlet'; 7 | resources bugtracker => 'https://github.com/kazuho/Starlet/issues'; 8 | 9 | requires 'Plack' => 0.9920; 10 | requires 'Parallel::Prefork' => 0.18; 11 | 12 | requires 'Server::Starter' => 0.06; 13 | test_requires 'Test::More' => 0.88; 14 | test_requires 'Test::TCP' => 2.10; 15 | test_requires 'LWP::UserAgent' => 5.80; 16 | 17 | WriteAll; 18 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | Starlet - a simple, high-performance PSGI/Plack HTTP server 3 | 4 | SYNOPSIS 5 | % start_server --port=80 -- plackup -s Starlet [options] your-app.psgi 6 | 7 | or if you do not need hot deploy, 8 | 9 | % plackup -s Starlet --port=80 [options] your-app.psgi 10 | 11 | DESCRIPTION 12 | Starlet is a standalone HTTP/1.1 web server, formerly known as 13 | Plack::Server::Standalone::Prefork and 14 | Plack::Server::Standalone::Prefork::Server::Starter. 15 | 16 | The server supports following features, and is suitable for running HTTP 17 | application servers behind a reverse proxy. 18 | 19 | - prefork and graceful shutdown using Parallel::Prefork 20 | 21 | - hot deploy using Server::Starter 22 | 23 | - fast HTTP processing using HTTP::Parser::XS (optional) 24 | 25 | COMMAND LINE OPTIONS 26 | In addition to the options supported by plackup, Starlet accepts 27 | following options(s). 28 | 29 | --max-workers=# 30 | number of worker processes (default: 10) 31 | 32 | --timeout=# 33 | seconds until timeout (default: 300) 34 | 35 | --keepalive-timeout=# 36 | timeout for persistent connections (default: 2) 37 | 38 | --max-keepalive-reqs=# 39 | max. number of requests allowed per single persistent connection. If set 40 | to one, persistent connections are disabled (default: 1) 41 | 42 | --max-reqs-per-child=# 43 | max. number of requests to be handled before a worker process exits 44 | (default: 100) 45 | 46 | --min-reqs-per-child=# 47 | if set, randomizes the number of requests handled by a single worker 48 | process between the value and that supplied by "--max-reqs-per-chlid" 49 | (default: none) 50 | 51 | --spawn-interval=# 52 | if set, worker processes will not be spawned more than once than every 53 | given seconds. Also, when SIGHUP is being received, no more than one 54 | worker processes will be collected every given seconds. This feature is 55 | useful for doing a "slow-restart". See 56 | http://blog.kazuhooku.com/2011/04/web-serverstarter-parallelprefork.html 57 | for more information. (default: none) 58 | 59 | --child-exit=s 60 | the subroutine code to be executed right before a child process exits. 61 | e.g. "--child-exit='sub { POSIX::_exit(0) }'". (default: none) 62 | 63 | Extensions to PSGI 64 | psgix.informational 65 | Starlets exposes a callback named "psgix.informational" that can be used 66 | for sending an informational response. The callback accepts two 67 | arguments, the first argument being the status code and the second being 68 | an arrayref of the headers to be sent. Example below sends an 103 69 | response before processing the request to build a final response. 70 | 71 | sub { 72 | my $env = shift; 73 | $env["psgix.informational"}->(103, [ 74 | 'link' => '; rel=preload' 75 | ]); 76 | my $resp = ... application logic ... 77 | $resp; 78 | } 79 | 80 | NOTES 81 | Starlet is designed and implemented to be simple, secure and fast, 82 | especially for running as an HTTP application server running behind a 83 | reverse proxy. It only depends on a minimal number of well-designed (and 84 | well-focused) modules. 85 | 86 | SEE ALSO 87 | Parallel::Prefork Starman Server::Starter 88 | 89 | AUTHOR 90 | Kazuho Oku 91 | 92 | miyagawa 93 | 94 | kazeburo 95 | 96 | Tomohiro Takezawa 97 | 98 | LICENSE 99 | This program is free software; you can redistribute it and/or modify it 100 | under the same terms as Perl itself. 101 | 102 | See 103 | 104 | -------------------------------------------------------------------------------- /lib/Plack/Handler/Starlet.pm: -------------------------------------------------------------------------------- 1 | package Plack::Handler::Starlet; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Parallel::Prefork; 7 | use Server::Starter (); 8 | use base qw(Starlet::Server); 9 | 10 | sub new { 11 | my ($klass, %args) = @_; 12 | 13 | # setup before instantiation 14 | if (defined $ENV{SERVER_STARTER_PORT}) { 15 | $args{listens} = []; 16 | my $server_ports = Server::Starter::server_ports(); 17 | for my $hostport (keys %$server_ports) { 18 | my $fd = $server_ports->{$hostport}; 19 | my $listen = {}; 20 | if ($hostport =~ /(.*):(\d+)/) { 21 | $listen->{host} = $1; 22 | $listen->{port} = $2; 23 | } else { 24 | $listen->{port} = $hostport; 25 | } 26 | $listen->{sock} = IO::Socket::INET->new( 27 | Proto => 'tcp', 28 | ) or die "failed to create socket:$!"; 29 | $listen->{sock}->fdopen($fd, 'w') 30 | or die "failed to bind to listening socket:$!"; 31 | unless (@{$args{listens}}) { 32 | $args{host} = $listen->{host}; 33 | $args{port} = $listen->{port}; 34 | } 35 | $args{listens}[$fd] = $listen; 36 | } 37 | } 38 | my $max_workers = 10; 39 | for (qw(max_workers workers)) { 40 | $max_workers = delete $args{$_} 41 | if defined $args{$_}; 42 | } 43 | 44 | if ($args{child_exit}) { 45 | $args{child_exit} = eval $args{child_exit} unless ref($args{child_exit}); 46 | die "child_exit is defined but not a code block" if ref($args{child_exit}) ne 'CODE'; 47 | } 48 | 49 | # instantiate and set the variables 50 | my $self = $klass->SUPER::new(%args); 51 | $self->{is_multiprocess} = 1; 52 | $self->{max_workers} = $max_workers; 53 | 54 | $self; 55 | } 56 | 57 | sub run { 58 | my($self, $app) = @_; 59 | $self->setup_listener(); 60 | if ($self->{max_workers} != 0) { 61 | # use Parallel::Prefork 62 | my %pm_args = ( 63 | max_workers => $self->{max_workers}, 64 | trap_signals => { 65 | TERM => 'TERM', 66 | HUP => 'TERM', 67 | }, 68 | ); 69 | if (defined $self->{spawn_interval}) { 70 | $pm_args{trap_signals}{USR1} = [ 'TERM', $self->{spawn_interval} ]; 71 | $pm_args{spawn_interval} = $self->{spawn_interval}; 72 | } 73 | if (defined $self->{err_respawn_interval}) { 74 | $pm_args{err_respawn_interval} = $self->{err_respawn_interval}; 75 | } 76 | my $pm = Parallel::Prefork->new(\%pm_args); 77 | while ($pm->signal_received !~ /^(TERM|USR1)$/) { 78 | $pm->start and next; 79 | srand((rand() * 2 ** 30) ^ $$ ^ time); 80 | $self->accept_loop($app, $self->_calc_reqs_per_child()); 81 | $pm->finish; 82 | } 83 | my $timeout = 1; 84 | if ($self->{spawn_interval}) { 85 | $timeout = $self->{spawn_interval} * $self->{max_workers} 86 | } 87 | while ($pm->wait_all_children($timeout)) { 88 | $pm->signal_all_children('TERM'); 89 | } 90 | } else { 91 | # run directly, mainly for debugging 92 | local $SIG{TERM} = sub { exit 0; }; 93 | while (1) { 94 | $self->accept_loop($app, $self->_calc_reqs_per_child()); 95 | } 96 | } 97 | } 98 | 99 | sub _calc_reqs_per_child { 100 | my $self = shift; 101 | my $max = $self->{max_reqs_per_child}; 102 | if (my $min = $self->{min_reqs_per_child}) { 103 | return $max - int(($max - $min + 1) * rand); 104 | } else { 105 | return $max; 106 | } 107 | } 108 | 109 | 1; 110 | -------------------------------------------------------------------------------- /lib/Starlet.pm: -------------------------------------------------------------------------------- 1 | package Starlet; 2 | 3 | use 5.008_001; 4 | 5 | our $VERSION = '0.31'; 6 | 7 | 1; 8 | __END__ 9 | 10 | =head1 NAME 11 | 12 | Starlet - a simple, high-performance PSGI/Plack HTTP server 13 | 14 | =head1 SYNOPSIS 15 | 16 | % start_server --port=80 -- plackup -s Starlet [options] your-app.psgi 17 | 18 | or if you do not need hot deploy, 19 | 20 | % plackup -s Starlet --port=80 [options] your-app.psgi 21 | 22 | =head1 DESCRIPTION 23 | 24 | Starlet is a standalone HTTP/1.1 web server, formerly known as L and L. 25 | 26 | The server supports following features, and is suitable for running HTTP application servers behind a reverse proxy. 27 | 28 | - prefork and graceful shutdown using L 29 | 30 | - hot deploy using L 31 | 32 | - fast HTTP processing using L (optional) 33 | 34 | =head1 COMMAND LINE OPTIONS 35 | 36 | In addition to the options supported by L, Starlet accepts following options(s). 37 | 38 | =head2 --max-workers=# 39 | 40 | number of worker processes (default: 10) 41 | 42 | =head2 --timeout=# 43 | 44 | seconds until timeout (default: 300) 45 | 46 | =head2 --keepalive-timeout=# 47 | 48 | timeout for persistent connections (default: 2) 49 | 50 | =head2 --max-keepalive-reqs=# 51 | 52 | max. number of requests allowed per single persistent connection. If set to one, persistent connections are disabled (default: 1) 53 | 54 | =head2 --max-reqs-per-child=# 55 | 56 | max. number of requests to be handled before a worker process exits (default: 100) 57 | 58 | =head2 --min-reqs-per-child=# 59 | 60 | if set, randomizes the number of requests handled by a single worker process between the value and that supplied by C<--max-reqs-per-chlid> (default: none) 61 | 62 | =head2 --spawn-interval=# 63 | 64 | if set, worker processes will not be spawned more than once than every given seconds. Also, when SIGHUP is being received, no more than one worker processes will be collected every given seconds. This feature is useful for doing a "slow-restart". See http://blog.kazuhooku.com/2011/04/web-serverstarter-parallelprefork.html for more information. (default: none) 65 | 66 | =head2 --child-exit=s 67 | 68 | the subroutine code to be executed right before a child process exits. e.g. C<--child-exit='sub { POSIX::_exit(0) }'>. (default: none) 69 | 70 | =head1 Extensions to PSGI 71 | 72 | =head2 psgix.informational 73 | 74 | Starlets exposes a callback named C that can be used for sending an informational response. 75 | The callback accepts two arguments, the first argument being the status code and the second being an arrayref of the headers to be sent. 76 | Example below sends an 103 response before processing the request to build a final response. 77 | 78 | sub { 79 | my $env = shift; 80 | $env["psgix.informational"}->(103, [ 81 | 'link' => '; rel=preload' 82 | ]); 83 | my $resp = ... application logic ... 84 | $resp; 85 | } 86 | 87 | =head1 NOTES 88 | 89 | L is designed and implemented to be simple, secure and fast, especially for running as an HTTP application server running behind a reverse proxy. It only depends on a minimal number of well-designed (and well-focused) modules. 90 | 91 | =head1 SEE ALSO 92 | 93 | L 94 | L 95 | L 96 | 97 | =head1 AUTHOR 98 | 99 | Kazuho Oku 100 | 101 | miyagawa 102 | 103 | kazeburo 104 | 105 | Tomohiro Takezawa 106 | 107 | =head1 LICENSE 108 | 109 | This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 110 | 111 | See L 112 | 113 | =cut 114 | -------------------------------------------------------------------------------- /lib/Starlet/Server.pm: -------------------------------------------------------------------------------- 1 | package Starlet::Server; 2 | use strict; 3 | use warnings; 4 | 5 | use Carp (); 6 | use Plack; 7 | use Plack::HTTPParser qw( parse_http_request ); 8 | use IO::Socket::INET; 9 | use HTTP::Date; 10 | use HTTP::Status; 11 | use List::Util qw(max sum); 12 | use Plack::Util; 13 | use Plack::TempBuffer; 14 | use POSIX qw(EINTR EAGAIN EWOULDBLOCK); 15 | use Socket qw(IPPROTO_TCP TCP_NODELAY); 16 | use File::Temp qw(tempfile); 17 | use Fcntl qw(:flock); 18 | 19 | use Try::Tiny; 20 | use Time::HiRes qw(time); 21 | 22 | use constant MAX_REQUEST_SIZE => 131072; 23 | use constant CHUNKSIZE => 64 * 1024; 24 | use constant MSWin32 => $^O eq 'MSWin32'; 25 | 26 | my $null_io = do { open my $io, "<", \""; $io }; 27 | 28 | sub new { 29 | my($class, %args) = @_; 30 | 31 | my $self = bless { 32 | listens => $args{listens} || [], 33 | host => $args{host} || 0, 34 | port => $args{port} || $args{socket} || 8080, 35 | timeout => $args{timeout} || 300, 36 | keepalive_timeout => $args{keepalive_timeout} || 2, 37 | max_keepalive_reqs => $args{max_keepalive_reqs} || 1, 38 | server_software => $args{server_software} || $class, 39 | server_ready => $args{server_ready} || sub {}, 40 | min_reqs_per_child => ( 41 | defined $args{min_reqs_per_child} 42 | ? $args{min_reqs_per_child} : undef, 43 | ), 44 | max_reqs_per_child => ( 45 | $args{max_reqs_per_child} || $args{max_requests} || 100, 46 | ), 47 | spawn_interval => $args{spawn_interval} || 0, 48 | err_respawn_interval => ( 49 | defined $args{err_respawn_interval} 50 | ? $args{err_respawn_interval} : undef, 51 | ), 52 | is_multiprocess => Plack::Util::FALSE, 53 | child_exit => $args{child_exit} || sub {}, 54 | _using_defer_accept => undef, 55 | }, $class; 56 | 57 | if ($args{max_workers} && $args{max_workers} > 1) { 58 | Carp::carp( 59 | "Preforking in $class is deprecated. Falling back to the non-forking mode. ", 60 | "If you need preforking, use Starman or Starlet instead and run like `plackup -s Starlet`", 61 | ); 62 | } 63 | 64 | $self; 65 | } 66 | 67 | sub run { 68 | my($self, $app) = @_; 69 | $self->setup_listener(); 70 | $self->accept_loop($app); 71 | } 72 | 73 | sub setup_listener { 74 | my $self = shift; 75 | if (scalar(grep {defined $_} @{$self->{listens}}) == 0) { 76 | my $sock; 77 | if ($self->{port} =~ /^[0-9]+$/s) { 78 | $sock = IO::Socket::INET->new( 79 | Listen => SOMAXCONN, 80 | LocalPort => $self->{port}, 81 | LocalAddr => $self->{host}, 82 | Proto => 'tcp', 83 | ReuseAddr => 1, 84 | ) or die "failed to listen to port $self->{port}:$!"; 85 | } else { 86 | $sock = IO::Socket::UNIX->new( 87 | Listen => SOMAXCONN, 88 | Local => $self->{port}, 89 | ) or die "failed to listen to socket $self->{port}:$!"; 90 | } 91 | $self->{listens}[fileno($sock)] = { 92 | host => $self->{host}, 93 | port => $self->{port}, 94 | sock => $sock, 95 | }; 96 | } 97 | 98 | my @listens = grep {defined $_} @{$self->{listens}}; 99 | for my $listen (@listens) { 100 | my $family = Socket::sockaddr_family(getsockname($listen->{sock})); 101 | $listen->{_is_tcp} = $family != AF_UNIX; 102 | 103 | # set defer accept 104 | if ($^O eq 'linux' && $listen->{_is_tcp}) { 105 | setsockopt($listen->{sock}, IPPROTO_TCP, 9, 1) 106 | and $listen->{_using_defer_accept} = 1; 107 | } 108 | } 109 | 110 | if (scalar(@listens) > 1) { 111 | $self->{lock_path} ||= do { 112 | my ($fh, $lock_path) = tempfile(UNLINK => 1); 113 | # closing the file handle explicitly for two reasons 114 | # 1) tempfile retains the handle when UNLINK is set 115 | # 2) tempfile implicitely locks the file on OS X 116 | close $fh; 117 | $lock_path; 118 | }; 119 | } 120 | 121 | $self->{server_ready}->($self); 122 | } 123 | 124 | sub accept_loop { 125 | # TODO handle $max_reqs_per_child 126 | my($self, $app, $max_reqs_per_child) = @_; 127 | my $proc_req_count = 0; 128 | my $is_keepalive = 0; 129 | 130 | local $SIG{TERM} = sub { 131 | $self->{term_received} = 1; 132 | }; 133 | local $SIG{PIPE} = 'IGNORE'; 134 | 135 | my $acceptor = $self->_get_acceptor; 136 | 137 | while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) { 138 | # accept (or exit on SIGTERM) 139 | if ($self->{term_received}) { 140 | $self->{child_exit}->($self, $app); 141 | exit 0; 142 | } 143 | my ($conn, $peer, $listen) = $acceptor->(); 144 | next unless $conn; 145 | 146 | $self->{_is_deferred_accept} = $listen->{_using_defer_accept}; 147 | defined($conn->blocking(0)) 148 | or die "failed to set socket to nonblocking mode:$!"; 149 | my ($peerport, $peerhost, $peeraddr) = (0, undef, undef); 150 | if ($listen->{_is_tcp}) { 151 | $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1) 152 | or die "setsockopt(TCP_NODELAY) failed:$!"; 153 | ($peerport, $peerhost) = unpack_sockaddr_in $peer; 154 | $peeraddr = inet_ntoa($peerhost); 155 | } 156 | my $req_count = 0; 157 | my $pipelined_buf = ''; 158 | 159 | while (1) { 160 | ++$req_count; 161 | ++$proc_req_count; 162 | my $env = { 163 | SERVER_PORT => $listen->{port} || 0, 164 | SERVER_NAME => $listen->{host} || 0, 165 | SCRIPT_NAME => '', 166 | REMOTE_ADDR => $peeraddr, 167 | REMOTE_PORT => $peerport, 168 | 'psgi.version' => [ 1, 1 ], 169 | 'psgi.errors' => *STDERR, 170 | 'psgi.url_scheme' => 'http', 171 | 'psgi.run_once' => Plack::Util::FALSE, 172 | 'psgi.multithread' => Plack::Util::FALSE, 173 | 'psgi.multiprocess' => $self->{is_multiprocess}, 174 | 'psgi.streaming' => Plack::Util::TRUE, 175 | 'psgi.nonblocking' => Plack::Util::FALSE, 176 | 'psgix.input.buffered' => Plack::Util::TRUE, 177 | 'psgix.io' => $conn, 178 | 'psgix.harakiri' => 1, 179 | 'psgix.informational' => sub { 180 | $self->_informational($conn, @_); 181 | }, 182 | }; 183 | 184 | my $may_keepalive = $req_count < $self->{max_keepalive_reqs}; 185 | if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) { 186 | $may_keepalive = undef; 187 | } 188 | $may_keepalive = 1 if length $pipelined_buf; 189 | my $keepalive; 190 | ($keepalive, $pipelined_buf) = $self->handle_connection($env, $conn, $app, 191 | $may_keepalive, $req_count != 1, $pipelined_buf); 192 | 193 | if ($env->{'psgix.harakiri.commit'}) { 194 | $conn->close; 195 | return; 196 | } 197 | last unless $keepalive; 198 | # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies 199 | } 200 | $conn->close; 201 | } 202 | } 203 | 204 | sub _get_acceptor { 205 | my $self = shift; 206 | my @listens = grep {defined $_} @{$self->{listens}}; 207 | 208 | if (scalar(@listens) == 1) { 209 | my $listen = $listens[0]; 210 | return sub { 211 | if (my ($conn, $peer) = $listen->{sock}->accept) { 212 | return ($conn, $peer, $listen); 213 | } 214 | return +(); 215 | }; 216 | } 217 | else { 218 | # wait for multiple sockets with select(2) 219 | my @fds; 220 | my $rin = ''; 221 | for my $listen (@listens) { 222 | defined($listen->{sock}->blocking(0)) 223 | or die "failed to set listening socket to non-blocking mode:$!"; 224 | my $fd = fileno($listen->{sock}); 225 | push @fds, $fd; 226 | vec($rin, $fd, 1) = 1; 227 | } 228 | 229 | open(my $lock_fh, '>', $self->{lock_path}) 230 | or die "failed to open lock file:@{[$self->{lock_path}]}:$!"; 231 | 232 | return sub { 233 | if (! flock($lock_fh, LOCK_EX)) { 234 | die "failed to lock file:@{[$self->{lock_path}]}:$!" 235 | if $! != EINTR; 236 | return +(); 237 | } 238 | my $nfound = select(my $rout = $rin, undef, undef, undef); 239 | for (my $i = 0; $nfound > 0; ++$i) { 240 | my $fd = $fds[$i]; 241 | next unless vec($rout, $fd, 1); 242 | --$nfound; 243 | my $listen = $self->{listens}[$fd]; 244 | if (my ($conn, $peer) = $listen->{sock}->accept) { 245 | flock($lock_fh, LOCK_UN); 246 | return ($conn, $peer, $listen); 247 | } 248 | } 249 | flock($lock_fh, LOCK_UN); 250 | return +(); 251 | }; 252 | } 253 | } 254 | 255 | my $bad_response = [ 400, [ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Bad Request' ] ]; 256 | sub handle_connection { 257 | my($self, $env, $conn, $app, $use_keepalive, $is_keepalive, $prebuf) = @_; 258 | 259 | my $buf = ''; 260 | my $pipelined_buf=''; 261 | my $res = $bad_response; 262 | 263 | while (1) { 264 | my $rlen; 265 | if ( $rlen = length $prebuf ) { 266 | $buf = $prebuf; 267 | undef $prebuf; 268 | } 269 | else { 270 | $rlen = $self->read_timeout( 271 | $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf), 272 | $is_keepalive ? $self->{keepalive_timeout} : $self->{timeout}, 273 | ) or return; 274 | } 275 | my $reqlen = parse_http_request($buf, $env); 276 | if ($reqlen >= 0) { 277 | # handle request 278 | my $protocol = $env->{SERVER_PROTOCOL}; 279 | if ($use_keepalive) { 280 | if ($self->{term_received}) { 281 | $use_keepalive = undef; 282 | } elsif ( $protocol eq 'HTTP/1.1' ) { 283 | if (my $c = $env->{HTTP_CONNECTION}) { 284 | $use_keepalive = undef 285 | if $c =~ /^\s*close\s*/i; 286 | } 287 | } else { 288 | if (my $c = $env->{HTTP_CONNECTION}) { 289 | $use_keepalive = undef 290 | unless $c =~ /^\s*keep-alive\s*/i; 291 | } else { 292 | $use_keepalive = undef; 293 | } 294 | } 295 | } 296 | $buf = substr $buf, $reqlen; 297 | my $chunked = do { no warnings; lc delete $env->{HTTP_TRANSFER_ENCODING} eq 'chunked' }; 298 | 299 | # If a message is received with both a Transfer-Encoding and a 300 | # Content-Length header field, the Transfer-Encoding overrides the 301 | # Content-Length. Such a message might indicate an attempt to 302 | # perform request smuggling (Section 9.5) or response splitting 303 | # (Section 9.4) and ought to be handled as an error. A sender MUST 304 | # remove the received Content-Length field prior to forwarding such 305 | # a message downstream. 306 | if ($chunked && $env->{CONTENT_LENGTH}) { 307 | delete $env->{CONTENT_LENGTH}; 308 | } 309 | 310 | if ( $env->{HTTP_EXPECT} ) { 311 | if ( lc $env->{HTTP_EXPECT} eq '100-continue' ) { 312 | $self->write_all($conn, "HTTP/1.1 100 Continue\015\012\015\012") 313 | or return; 314 | } else { 315 | $res = [417,[ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Expectation Failed' ] ]; 316 | last; 317 | } 318 | } 319 | 320 | if (my $cl = $env->{CONTENT_LENGTH}) { 321 | if ($cl !~ /^[0-9]+$/) { # content-length header must be digits. 322 | last; # Return bad response 323 | } 324 | 325 | my $buffer = Plack::TempBuffer->new($cl); 326 | while ($cl > 0) { 327 | my $chunk; 328 | if (length $buf) { 329 | $chunk = $buf; 330 | $buf = ''; 331 | } else { 332 | $self->read_timeout( 333 | $conn, \$chunk, $cl, 0, $self->{timeout}) 334 | or return; 335 | } 336 | $buffer->print($chunk); 337 | $cl -= length $chunk; 338 | } 339 | $env->{'psgi.input'} = $buffer->rewind; 340 | } 341 | elsif ($chunked) { 342 | my $buffer = Plack::TempBuffer->new; 343 | my $chunk_buffer = ''; 344 | my $length; 345 | DECHUNK: while(1) { 346 | my $chunk; 347 | if ( length $buf ) { 348 | $chunk = $buf; 349 | $buf = ''; 350 | } 351 | else { 352 | $self->read_timeout($conn, \$chunk, CHUNKSIZE, 0, $self->{timeout}) 353 | or return; 354 | } 355 | 356 | $chunk_buffer .= $chunk; 357 | while ( $chunk_buffer =~ s/^(([0-9a-fA-F]+).*\015\012)// ) { 358 | my $trailer = $1; 359 | my $chunk_len = hex $2; 360 | if ($chunk_len == 0) { 361 | last DECHUNK; 362 | } elsif (length $chunk_buffer < $chunk_len + 2) { 363 | $chunk_buffer = $trailer . $chunk_buffer; 364 | last; 365 | } 366 | $buffer->print(substr $chunk_buffer, 0, $chunk_len, ''); 367 | $chunk_buffer =~ s/^\015\012//; 368 | $length += $chunk_len; 369 | } 370 | } 371 | $env->{CONTENT_LENGTH} = $length; 372 | $env->{'psgi.input'} = $buffer->rewind; 373 | } else { 374 | if ( $buf =~ m!^(?:GET|HEAD)! ) { #pipeline 375 | $pipelined_buf = $buf; 376 | $use_keepalive = 1; #force keepalive 377 | } # else clear buffer 378 | $env->{'psgi.input'} = $null_io; 379 | } 380 | 381 | $res = Plack::Util::run_app $app, $env; 382 | last; 383 | } 384 | if ($reqlen == -2) { 385 | # request is incomplete, do nothing 386 | } elsif ($reqlen == -1) { 387 | # error, close conn 388 | last; 389 | } 390 | } 391 | 392 | if (ref $res eq 'ARRAY') { 393 | $self->_handle_response($env->{SERVER_PROTOCOL}, $res, $conn, \$use_keepalive); 394 | } elsif (ref $res eq 'CODE') { 395 | $res->(sub { 396 | $self->_handle_response($env->{SERVER_PROTOCOL}, $_[0], $conn, \$use_keepalive); 397 | }); 398 | } else { 399 | die "Bad response $res"; 400 | } 401 | 402 | return ($use_keepalive, $pipelined_buf); 403 | } 404 | 405 | sub _informational { 406 | my ($self, $conn, $status_code, $headers) = @_; 407 | 408 | my @lines = "HTTP/1.1 $status_code @{[ HTTP::Status::status_message($status_code) ]}\015\012"; 409 | for (my $i = 0; $i < @$headers; $i += 2) { 410 | my $k = $headers->[$i]; 411 | my $v = $headers->[$i + 1]; 412 | push @lines, "$k: $v\015\012"; 413 | } 414 | push @lines, "\015\012"; 415 | 416 | $self->write_all($conn, join("", @lines), $self->{timeout}); 417 | } 418 | 419 | sub _handle_response { 420 | my($self, $protocol, $res, $conn, $use_keepalive_r) = @_; 421 | my $status_code = $res->[0]; 422 | my $headers = $res->[1]; 423 | my $body = $res->[2]; 424 | 425 | my @lines; 426 | my %send_headers; 427 | for (my $i = 0; $i < @$headers; $i += 2) { 428 | my $k = $headers->[$i]; 429 | my $v = $headers->[$i + 1]; 430 | my $lck = lc $k; 431 | if ($lck eq 'connection') { 432 | $$use_keepalive_r = undef 433 | if $$use_keepalive_r && lc $v ne 'keep-alive'; 434 | } else { 435 | push @lines, "$k: $v\015\012"; 436 | $send_headers{$lck} = $v; 437 | } 438 | } 439 | if ( ! exists $send_headers{server} ) { 440 | unshift @lines, "Server: $self->{server_software}\015\012"; 441 | } 442 | if ( ! exists $send_headers{date} ) { 443 | unshift @lines, "Date: @{[HTTP::Date::time2str()]}\015\012"; 444 | } 445 | 446 | # try to set content-length when keepalive can be used, or disable it 447 | my $use_chunked; 448 | if (defined($protocol) && $protocol eq 'HTTP/1.1') { 449 | if (defined $send_headers{'content-length'} 450 | || defined $send_headers{'transfer-encoding'}) { 451 | # ok 452 | } elsif (!Plack::Util::status_with_no_entity_body($status_code)) { 453 | push @lines, "Transfer-Encoding: chunked\015\012"; 454 | $use_chunked = 1; 455 | } 456 | push @lines, "Connection: close\015\012" unless $$use_keepalive_r; 457 | } else { 458 | # HTTP/1.0 459 | if ($$use_keepalive_r) { 460 | if (defined $send_headers{'content-length'} 461 | || defined $send_headers{'transfer-encoding'}) { 462 | # ok 463 | } elsif (!Plack::Util::status_with_no_entity_body($status_code) 464 | && defined(my $cl = Plack::Util::content_length($body))) { 465 | push @lines, "Content-Length: $cl\015\012"; 466 | } else { 467 | $$use_keepalive_r = undef; 468 | } 469 | } 470 | push @lines, "Connection: keep-alive\015\012" if $$use_keepalive_r; 471 | push @lines, "Connection: close\015\012" if !$$use_keepalive_r; #fmm.. 472 | } 473 | 474 | unshift @lines, "HTTP/1.1 $status_code @{[ HTTP::Status::status_message($status_code) ]}\015\012"; 475 | push @lines, "\015\012"; 476 | 477 | if (defined $body && ref $body eq 'ARRAY' && @$body == 1 478 | && length $body->[0] < 8192) { 479 | # combine response header and small request body 480 | my $buf = $body->[0]; 481 | if ($use_chunked ) { 482 | my $len = length $buf; 483 | $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012" . '0' . "\015\012\015\012"; 484 | } 485 | $self->write_all( 486 | $conn, join('', @lines, $buf), $self->{timeout}, 487 | ); 488 | return; 489 | } 490 | $self->write_all($conn, join('', @lines), $self->{timeout}) 491 | or return; 492 | 493 | if (defined $body) { 494 | my $failed; 495 | my $completed; 496 | my $body_count = (ref $body eq 'ARRAY') ? $#{$body} + 1 : -1; 497 | Plack::Util::foreach( 498 | $body, 499 | sub { 500 | unless ($failed) { 501 | my $buf = $_[0]; 502 | --$body_count; 503 | if ( $use_chunked ) { 504 | my $len = length $buf; 505 | return unless $len; 506 | $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012"; 507 | if ( $body_count == 0 ) { 508 | $buf .= '0' . "\015\012\015\012"; 509 | $completed = 1; 510 | } 511 | } 512 | $self->write_all($conn, $buf, $self->{timeout}) 513 | or $failed = 1; 514 | } 515 | }, 516 | ); 517 | $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked && !$completed; 518 | } else { 519 | return Plack::Util::inline_object 520 | write => sub { 521 | my $buf = $_[0]; 522 | if ( $use_chunked ) { 523 | my $len = length $buf; 524 | return unless $len; 525 | $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012" 526 | } 527 | $self->write_all($conn, $buf, $self->{timeout}) 528 | }, 529 | close => sub { 530 | $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked; 531 | }; 532 | } 533 | } 534 | 535 | # returns value returned by $cb, or undef on timeout or network error 536 | sub do_io { 537 | my ($self, $is_write, $sock, $buf, $len, $off, $timeout) = @_; 538 | my $ret; 539 | unless ($is_write || delete $self->{_is_deferred_accept}) { 540 | goto DO_SELECT; 541 | } 542 | DO_READWRITE: 543 | # try to do the IO 544 | if ($is_write) { 545 | $ret = syswrite $sock, $buf, $len, $off 546 | and return $ret; 547 | } else { 548 | $ret = sysread $sock, $$buf, $len, $off 549 | and return $ret; 550 | } 551 | unless ((! defined($ret) 552 | && ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK))) { 553 | return; 554 | } 555 | # wait for data 556 | DO_SELECT: 557 | while (1) { 558 | my ($rfd, $wfd); 559 | my $efd = ''; 560 | vec($efd, fileno($sock), 1) = 1; 561 | if ($is_write) { 562 | ($rfd, $wfd) = ('', $efd); 563 | } else { 564 | ($rfd, $wfd) = ($efd, ''); 565 | } 566 | my $start_at = time; 567 | my $nfound = select($rfd, $wfd, $efd, $timeout); 568 | $timeout -= (time - $start_at); 569 | last if $nfound; 570 | return if $timeout <= 0; 571 | } 572 | goto DO_READWRITE; 573 | } 574 | 575 | # returns (positive) number of bytes read, or undef if the socket is to be closed 576 | sub read_timeout { 577 | my ($self, $sock, $buf, $len, $off, $timeout) = @_; 578 | $self->do_io(undef, $sock, $buf, $len, $off, $timeout); 579 | } 580 | 581 | # returns (positive) number of bytes written, or undef if the socket is to be closed 582 | sub write_timeout { 583 | my ($self, $sock, $buf, $len, $off, $timeout) = @_; 584 | $self->do_io(1, $sock, $buf, $len, $off, $timeout); 585 | } 586 | 587 | # writes all data in buf and returns number of bytes written or undef if failed 588 | sub write_all { 589 | my ($self, $sock, $buf, $timeout) = @_; 590 | my $off = 0; 591 | while (my $len = length($buf) - $off) { 592 | my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout) 593 | or return; 594 | $off += $ret; 595 | } 596 | return length $buf; 597 | } 598 | 599 | 1; 600 | -------------------------------------------------------------------------------- /t/00base-hello.psgi: -------------------------------------------------------------------------------- 1 | my $handler = sub { 2 | return [ 200, [ "Content-Type" => "text/plain", "Content-Length" => 5 ], [ "hello" ] ]; 3 | }; 4 | -------------------------------------------------------------------------------- /t/00base.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use File::Basename (); 5 | use List::Util qw(first); 6 | use LWP::UserAgent (); 7 | use Test::TCP (); 8 | 9 | use Test::More; 10 | 11 | BEGIN { 12 | use_ok('Server::Starter'); 13 | }; 14 | 15 | sub findprog { 16 | my $prog = shift; 17 | first { -x $_ } map { "$_/$prog" } ( 18 | File::Basename::dirname($^X), 19 | split /:/, $ENV{PATH}, 20 | ); 21 | } 22 | 23 | my $start_server = findprog('start_server'); 24 | my $plackup = findprog('plackup'); 25 | 26 | sub doit { 27 | my $pkg = shift; 28 | my $port = Test::TCP::empty_port(); 29 | my $server_pid = fork(); 30 | die "fork failed:$!" 31 | unless defined $server_pid; 32 | if ($server_pid == 0) { 33 | # child == server 34 | exec( 35 | $start_server, 36 | "--port=$port", 37 | '--', 38 | $plackup, 39 | '--server', 40 | $pkg, 41 | 't/00base-hello.psgi', 42 | ); 43 | die "failed to launch server using start_server:$!"; 44 | } 45 | sleep 1; 46 | 47 | my $ua = LWP::UserAgent->new; 48 | my $response = $ua->get("http://127.0.0.1:$port/"); 49 | ok($response->is_success, "request successfull"); 50 | is($response->content, 'hello', 'content is hello'); 51 | 52 | kill 'TERM', $server_pid; 53 | while (wait == -1) {} 54 | } 55 | 56 | if ($start_server) { 57 | doit('Starlet'); 58 | } else { 59 | warn "could not find `start_server' next to $^X nor from \$PATH, skipping tests"; 60 | } 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t/01plack-test.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | use Plack::Test::Suite; 4 | 5 | Plack::Test::Suite->run_server_tests('Starlet'); 6 | done_testing(); 7 | 8 | -------------------------------------------------------------------------------- /t/02graceful.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use HTTP::Request::Common; 5 | use Plack::Test; 6 | use Test::More; 7 | 8 | $Plack::Test::Impl = 'Server'; 9 | $ENV{PLACK_SERVER} = 'Starlet'; 10 | 11 | warn $$; 12 | 13 | test_psgi 14 | app => sub { 15 | my $env = shift; 16 | warn $$; 17 | unless (my $pid = fork) { 18 | die "fork failed:$!" 19 | unless defined $pid; 20 | # child process 21 | sleep 1; 22 | kill 'TERM', getppid(); 23 | exit 0; 24 | } 25 | sleep 5; 26 | return [ 200, [ 'Content-Type' => 'text/plain' ], [ "hello world" ] ]; 27 | }, 28 | client => sub { 29 | my $cb = shift; 30 | warn $$; 31 | my $res = $cb->(GET "/"); 32 | is $res->content, "hello world"; 33 | }; 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/03post.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use LWP::UserAgent; 5 | use Plack::Runner; 6 | use Test::More; 7 | use Test::TCP; 8 | 9 | warn $$; 10 | 11 | test_tcp( 12 | server => sub { 13 | my $port = shift; 14 | my $runner = Plack::Runner->new; 15 | $runner->parse_options( 16 | qw(--server Starlet --max-workers 0 --port), $port, 17 | ); 18 | $runner->run( 19 | sub { 20 | my $env = shift; 21 | my $buf = ''; 22 | while (length($buf) != $env->{CONTENT_LENGTH}) { 23 | my $rlen = $env->{'psgi.input'}->read( 24 | $buf, 25 | $env->{CONTENT_LENGTH} - length($buf), 26 | length($buf), 27 | ); 28 | last unless $rlen > 0; 29 | } 30 | return [ 31 | 200, 32 | [ 'Content-Type' => 'text/plain' ], 33 | [ $buf ], 34 | ]; 35 | }, 36 | ); 37 | }, 38 | client => sub { 39 | my $port = shift; 40 | note 'send a broken request'; 41 | my $sock = IO::Socket::INET->new( 42 | PeerAddr => "127.0.0.1:$port", 43 | Proto => 'tcp', 44 | ) or die "failed to connect to server:$!"; 45 | $sock->print(<< "EOT"); 46 | POST / HTTP/1.0\r 47 | Content-Length: 6\r 48 | \r 49 | EOT 50 | undef $sock; 51 | note 'send next request'; 52 | my $ua = LWP::UserAgent->new; 53 | $ua->timeout(10); 54 | my $res = $ua->post("http://127.0.0.1:$port/", { a => 1 }); 55 | ok $res->is_success; 56 | is $res->code, 200; 57 | is $res->content, 'a=1'; 58 | }, 59 | ); 60 | 61 | done_testing; 62 | -------------------------------------------------------------------------------- /t/04-bumpy-life.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Plack::Loader; 5 | use Test::More; 6 | use Test::TCP qw(empty_port); 7 | 8 | my $starlet = Plack::Loader->load( 9 | 'Starlet', 10 | min_reqs_per_child => 5, 11 | max_reqs_per_child => 10, 12 | ); 13 | 14 | my ($min, $max) = (7, 7); 15 | for (my $i = 0; $i < 10000; $i++) { 16 | my $n = $starlet->_calc_reqs_per_child(); 17 | $min = $n 18 | if $n < $min; 19 | $max = $n 20 | if $n > $max; 21 | } 22 | 23 | is $min, 5, "min"; 24 | is $max, 10, "max"; 25 | 26 | done_testing; 27 | -------------------------------------------------------------------------------- /t/05server-header.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::TCP; 5 | use LWP::UserAgent; 6 | use Plack::Loader; 7 | 8 | test_tcp( 9 | client => sub { 10 | my $port = shift; 11 | sleep 1; 12 | my $ua = LWP::UserAgent->new; 13 | my $res = $ua->get("http://localhost:$port/"); 14 | ok( $res->is_success ); 15 | like( scalar $res->header('Server'), qr/Starlet/ ); 16 | unlike( scalar $res->header('Server'), qr/Hello/ ); 17 | 18 | $res = $ua->get("http://localhost:$port/?server=1"); 19 | ok( $res->is_success ); 20 | unlike( scalar $res->header('Server'), qr/Starlet/ ); 21 | like( scalar $res->header('Server'), qr/Hello/ ); 22 | 23 | }, 24 | server => sub { 25 | my $port = shift; 26 | my $loader = Plack::Loader->load( 27 | 'Starlet', 28 | port => $port, 29 | max_workers => 5, 30 | ); 31 | $loader->run(sub{ 32 | my $env = shift; 33 | my @headers = ('Content-Type','text/html'); 34 | push @headers, 'Server', 'Hello' if $env->{QUERY_STRING}; 35 | [200, \@headers, ['HELLO']]; 36 | }); 37 | exit; 38 | }, 39 | ); 40 | 41 | done_testing; 42 | 43 | -------------------------------------------------------------------------------- /t/06harakiri.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use HTTP::Request::Common; 5 | use Plack::Test; 6 | use Test::More; 7 | 8 | $Plack::Test::Impl = 'Server'; 9 | $ENV{PLACK_SERVER} = 'Starlet'; 10 | 11 | test_psgi 12 | app => sub { 13 | my $env = shift; 14 | return [ 200, [ 'Content-Type' => 'text/plain' ], [$$] ]; 15 | }, 16 | client => sub { 17 | my %seen_pid; 18 | my $cb = shift; 19 | for (1..23) { 20 | my $res = $cb->(GET "/"); 21 | $seen_pid{$res->content}++; 22 | } 23 | cmp_ok(keys(%seen_pid), '<=', 10, 'In non-harakiri mode, pid is reused') 24 | }; 25 | 26 | test_psgi 27 | app => sub { 28 | my $env = shift; 29 | $env->{'psgix.harakiri.commit'} = $env->{'psgix.harakiri'}; 30 | return [ 200, [ 'Content-Type' => 'text/plain' ], [$$] ]; 31 | }, 32 | client => sub { 33 | my %seen_pid; 34 | my $cb = shift; 35 | for (1..23) { 36 | my $res = $cb->(GET "/"); 37 | $seen_pid{$res->content}++; 38 | } 39 | is keys(%seen_pid), 23, 'In Harakiri mode, each pid only used once'; 40 | }; 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/07remote_port.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::TCP; 5 | use LWP::UserAgent; 6 | use IO::Socket::INET; 7 | use Plack::Loader; 8 | 9 | test_tcp( 10 | client => sub { 11 | my $port = shift; 12 | sleep 1; 13 | my $sock = IO::Socket::INET->new( 14 | PeerAddr => "localhost:$port", 15 | Proto => 'tcp', 16 | ); 17 | ok($sock); 18 | my $localport = $sock->sockport; 19 | my $req = "GET / HTTP/1.0\015\012\015\012"; 20 | $sock->syswrite($req,length($req)); 21 | $sock->sysread( my $buf, 1024); 22 | like( $buf, qr/HELLO $localport/); 23 | }, 24 | server => sub { 25 | my $port = shift; 26 | my $loader = Plack::Loader->load( 27 | 'Starlet', 28 | port => $port, 29 | max_workers => 5, 30 | ); 31 | $loader->run(sub{ 32 | my $env = shift; 33 | my @headers = (); 34 | my $remote_port = $env->{REMOTE_PORT}; 35 | [200, ['Content-Type'=>'text/html'], ['HELLO '.$remote_port]]; 36 | }); 37 | exit; 38 | }, 39 | ); 40 | 41 | done_testing; 42 | 43 | -------------------------------------------------------------------------------- /t/08chunked_req.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::TCP; 3 | use Plack::Test; 4 | use HTTP::Request; 5 | use Test::More; 6 | use Digest::MD5; 7 | 8 | 9 | $Plack::Test::Impl = "Server"; 10 | $ENV{PLACK_SERVER} = 'Starlet'; 11 | 12 | my $file = "t/assets/baybridge.jpg"; 13 | 14 | my $app = sub { 15 | my $env = shift; 16 | my $body; 17 | my $clen = $env->{CONTENT_LENGTH}; 18 | while ($clen > 0) { 19 | $env->{'psgi.input'}->read(my $buf, $clen) or last; 20 | $clen -= length $buf; 21 | $body .= $buf; 22 | } 23 | return [ 200, [ 'Content-Type', 'text/plain', 'X-Content-Length', $env->{CONTENT_LENGTH} ], [ $body ] ]; 24 | }; 25 | 26 | test_psgi $app, sub { 27 | my $cb = shift; 28 | 29 | open my $fh, "<:raw", $file; 30 | local $/ = \1024; 31 | 32 | my $req = HTTP::Request->new(POST => "http://localhost/"); 33 | $req->content(sub { scalar <$fh> }); 34 | 35 | my $res = $cb->($req); 36 | 37 | is $res->header('X-Content-Length'), 79838; 38 | is Digest::MD5::md5_hex($res->content), '983726ae0e4ce5081bef5fb2b7216950'; 39 | }; 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/09chunked_zero_length.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::TCP; 3 | use Plack::Test; 4 | use HTTP::Request; 5 | use Test::More; 6 | 7 | 8 | $Plack::Test::Impl = "Server"; 9 | $ENV{PLACK_SERVER} = 'Starlet'; 10 | 11 | my $app = sub { 12 | my $env = shift; 13 | return sub { 14 | my $response = shift; 15 | my $writer = $response->([ 200, [ 'Content-Type', 'text/plain' ]]); 16 | $writer->write("Content"); 17 | $writer->write(""); 18 | $writer->write("Again"); 19 | $writer->close; 20 | } 21 | }; 22 | 23 | test_psgi $app, sub { 24 | my $cb = shift; 25 | 26 | my $req = HTTP::Request->new(GET => "http://localhost/"); 27 | my $res = $cb->($req); 28 | 29 | is $res->content, "ContentAgain"; 30 | }; 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /t/10unix_domain_socket.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use File::Temp qw(tempfile); 3 | use IO::Socket::UNIX; 4 | use Plack::Loader; 5 | use Socket; 6 | use Test::More; 7 | 8 | (undef, my $sockfile) = tempfile(UNLINK => 0); 9 | unlink $sockfile; 10 | 11 | sub doit { 12 | my $create_loader = shift; 13 | 14 | my $pid = fork; 15 | die "fork failed:$!" 16 | unless defined $pid; 17 | if ($pid == 0) { 18 | # server 19 | my $loader = $create_loader->(); 20 | $loader->run(sub { 21 | my $env = shift; 22 | my $remote = $env->{REMOTE_ADDR}; 23 | $remote = 'UNIX' if ! defined $remote; 24 | return [ 25 | 200, 26 | ['Content-Type'=>'text/html'], 27 | ["HELLO $remote"], 28 | ]; 29 | }); 30 | exit; 31 | } 32 | 33 | sleep 1; 34 | 35 | my $client = IO::Socket::UNIX->new( 36 | Peer => $sockfile, 37 | timeout => 3, 38 | ) or die "failed to listen to socket $sockfile:$!"; 39 | 40 | $client->syswrite("GET / HTTP/1.0\015\012\015\012"); 41 | $client->sysread(my $buf, 1024); 42 | like $buf, qr/Starlet/; 43 | like $buf, qr/HELLO UNIX/; 44 | 45 | kill 'TERM', $pid; 46 | waitpid($pid, 0); 47 | unlink($sockfile); 48 | } 49 | 50 | subtest 'direct' => sub { 51 | doit(sub { 52 | return Plack::Loader->load( 53 | 'Starlet', 54 | max_workers => 5, 55 | socket => $sockfile, 56 | ); 57 | }); 58 | }; 59 | 60 | subtest 'server-starter' => sub { 61 | doit(sub { 62 | my $sock = IO::Socket::UNIX->new( 63 | Listen => Socket::SOMAXCONN(), 64 | Local => $sockfile, 65 | ) or die "failed to listen to socket $sockfile:$!"; 66 | $ENV{SERVER_STARTER_PORT} = "$sockfile=@{[$sock->fileno]}"; 67 | return Plack::Loader->load( 68 | 'Starlet', 69 | max_workers => 5, 70 | ); 71 | }); 72 | }; 73 | 74 | 75 | done_testing(); 76 | -------------------------------------------------------------------------------- /t/11multi-sockets.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Plack::Loader; 6 | use File::Temp; 7 | use IO::Socket::INET; 8 | use Net::EmptyPort qw(empty_port); 9 | use Socket; 10 | 11 | my $PORT_NUM = 3; 12 | my $UDS_NUM = 4; 13 | my $WORKER_NUM = 2; 14 | 15 | my @tcp_socks = map { 16 | IO::Socket::INET->new( 17 | Listen => Socket::SOMAXCONN(), 18 | Proto => 'tcp', 19 | LocalPort => empty_port(), 20 | LocalAddr => '127.0.0.1', 21 | ReuseAddr => 1, 22 | ) or die "failed to listen:$!"; 23 | } (1..$PORT_NUM); 24 | 25 | my @uds_socks = map { 26 | my ($fh, $filename) = File::Temp::tempfile(UNLINK=>0); 27 | close($fh); 28 | unlink($filename); 29 | IO::Socket::UNIX->new( 30 | Listen => Socket::SOMAXCONN(), 31 | Local => $filename, 32 | ) or die "failed to listen to socket $filename:$!"; 33 | } (1..$UDS_NUM); 34 | 35 | $ENV{SERVER_STARTER_PORT} = join ';', ( 36 | map($_->sockport.'='.$_->fileno, @tcp_socks), 37 | map($_->hostpath.'='.$_->fileno, @uds_socks), 38 | ); 39 | 40 | my $pid = fork; 41 | if ( $pid == 0 ) { 42 | # server 43 | my $loader = Plack::Loader->load( 44 | 'Starlet', 45 | max_workers => $WORKER_NUM, 46 | ); 47 | $loader->run(sub{ 48 | my $env = shift; 49 | [200, ['Content-Type'=>'text/html'], ["HELLO $env->{SERVER_PORT}"]]; 50 | }); 51 | exit; 52 | } 53 | 54 | sleep 1; 55 | 56 | for my $listen_sock (@tcp_socks, @uds_socks) { 57 | my ($client, $port); 58 | if ($listen_sock->sockdomain == AF_INET) { 59 | $port = $listen_sock->sockport; 60 | $client = IO::Socket::INET->new( 61 | Proto => 'tcp', 62 | PeerAddr => '127.0.0.1', 63 | PeerPort => $listen_sock->sockport, 64 | timeout => 3, 65 | ) or die "failed to connect to socket $port:$!"; 66 | } 67 | elsif ($listen_sock->sockdomain == AF_UNIX) { 68 | $port = $listen_sock->hostpath; 69 | $client = IO::Socket::UNIX->new( 70 | Peer => $port, 71 | timeout => 3, 72 | ) or die "failed to connect to socket $port:$!"; 73 | } 74 | else { 75 | die "unknown socket"; 76 | } 77 | 78 | $client->syswrite("GET / HTTP/1.0\015\012\015\012"); 79 | $client->sysread(my $buf, 1024); 80 | like $buf, qr/Starlet/; 81 | like $buf, qr/HELLO $port/; 82 | } 83 | 84 | done_testing(); 85 | 86 | kill 'TERM', $pid; 87 | waitpid($pid,0); 88 | -------------------------------------------------------------------------------- /t/12bad_request_line.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::TCP qw(test_tcp); 5 | use IO::Socket::INET; 6 | use Plack::Loader; 7 | 8 | test_tcp( 9 | client => sub { 10 | my $port = shift; 11 | my $sock = IO::Socket::INET->new( 12 | PeerAddr => "localhost:$port", 13 | Proto => 'tcp', 14 | ); 15 | my $req = "GET /bad request header/ HTTP/1.0\015\012\015\012"; 16 | $sock->syswrite($req, length $req); 17 | $sock->sysread(my $buf, 1024); 18 | like $buf, qr/\b400\b/; 19 | note $buf; 20 | }, 21 | server => sub { 22 | my $port = shift; 23 | local $SIG{__WARN__} = sub { 24 | ok 0, "No warnings"; 25 | diag @_; 26 | }; 27 | my $loader = Plack::Loader->load('Starlet', port => $port); 28 | $loader->run(sub { [200, ['Content-Type' => 'text/plain'], ['OK']] }); 29 | exit; 30 | }, 31 | ); 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /t/13expect.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::TCP; 5 | use LWP::UserAgent; 6 | use Plack::Loader; 7 | 8 | test_tcp( 9 | client => sub { 10 | my $port = shift; 11 | sleep 1; 12 | my $ua = LWP::UserAgent->new; 13 | my $res = $ua->post( 14 | "http://localhost:$port/", 15 | { blah => 1 }, 16 | Expect => '100-continue' 17 | ); 18 | ok( $res->is_success ); 19 | is( $res->content, 'HELLO', 'Expect header in standard case works' ); 20 | 21 | 22 | $res = $ua->post( 23 | "http://localhost:$port/", 24 | { blah => 1 }, 25 | Expect => '100-Continue' 26 | ); 27 | ok( $res->is_success ); 28 | is( $res->content, 'HELLO', 'Expect header is case insensitive' ); 29 | }, 30 | server => sub { 31 | my $port = shift; 32 | my $loader = Plack::Loader->load( 33 | 'Starlet', 34 | port => $port, 35 | max_workers => 5, 36 | ); 37 | $loader->run( 38 | sub { 39 | my $env = shift; 40 | [ 200, [], ['HELLO'] ]; 41 | } 42 | ); 43 | exit; 44 | }, 45 | ); 46 | 47 | done_testing; 48 | 49 | -------------------------------------------------------------------------------- /t/13spawn_interval.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use File::Basename (); 5 | use List::Util qw(first); 6 | use Test::TCP (); 7 | use File::Temp qw(tmpnam); 8 | 9 | use Test::More; 10 | 11 | BEGIN { 12 | use_ok('Server::Starter'); 13 | }; 14 | 15 | sub findprog { 16 | my $prog = shift; 17 | first { -x $_ } map { "$_/$prog" } ( 18 | File::Basename::dirname($^X), 19 | split /:/, $ENV{PATH}, 20 | ); 21 | } 22 | 23 | sub read_status_file { 24 | my $path = shift; 25 | open my $fh, $path or die "failed to open status file $path"; 26 | my $contents = do { local $/; <$fh> }; 27 | close $fh; 28 | my @pids = map { (split /:/, $_)[1] } split /\n/, $contents; 29 | return @pids; 30 | } 31 | 32 | my $start_server = findprog('start_server'); 33 | my $plackup = findprog('plackup'); 34 | 35 | sub doit { 36 | my $pkg = shift; 37 | my $port = Test::TCP::empty_port(); 38 | my $status_file_path = tmpnam(); 39 | my $server_pid = fork(); 40 | die "fork failed:$!" 41 | unless defined $server_pid; 42 | if ($server_pid == 0) { 43 | # child == server 44 | exec( 45 | $start_server, 46 | "--port=$port", 47 | "--status-file=$status_file_path", 48 | "--signal-on-hup=USR1", 49 | '--', 50 | $plackup, 51 | '--server', 52 | $pkg, 53 | '--max-workers=5', # just for finish test fast 54 | '--spawn-interval=1', 55 | 't/00base-hello.psgi', 56 | ); 57 | die "failed to launch server using start_server:$!"; 58 | } 59 | # wait until all workers spawn 60 | sleep 5; 61 | my @pids = read_status_file($status_file_path); 62 | my $sent_num_before_hup = kill 0, $pids[0]; 63 | 64 | kill 'HUP', $server_pid; 65 | 66 | sleep 4; 67 | my $sent_num_after_hup = kill 0, $pids[0]; 68 | is $sent_num_before_hup, 1, "process still alive before HUP signal"; 69 | is $sent_num_after_hup, 1, "old generation process still alive for a while after HUP signal"; 70 | sleep 1; 71 | kill 'TERM', $server_pid; 72 | while (wait == -1) {} 73 | } 74 | 75 | if ($start_server) { 76 | doit('Starlet'); 77 | } else { 78 | warn "could not find `start_server' next to $^X nor from \$PATH, skipping tests"; 79 | } 80 | 81 | done_testing; 82 | -------------------------------------------------------------------------------- /t/14child_finish_hook.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Plack::Runner; 6 | 7 | $SIG{CONT} = sub { pass('child_exit has been executed.') }; 8 | 9 | plan tests => 1; 10 | our $main_pid = $$; 11 | my $pid = fork; 12 | if ( $pid == 0 ) { 13 | my $runner = Plack::Runner->new; 14 | $runner->parse_options( 15 | qw(--server Starlet --max-workers 1 --child-exit), 16 | "sub { kill 'CONT', $main_pid }", 17 | ); 18 | $runner->run(sub{ 19 | my $env = shift; 20 | [200, ['Content-Type'=>'text/html'], ["HELLO"]]; 21 | }); 22 | exit 0; 23 | } 24 | 25 | sleep 1; 26 | 27 | kill 'TERM', $pid; 28 | waitpid($pid, 0); 29 | 30 | done_testing(); 31 | -------------------------------------------------------------------------------- /t/14interim_response.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::TCP qw(test_tcp); 5 | use IO::Socket::INET; 6 | use Plack::Loader; 7 | 8 | test_tcp( 9 | client => sub { 10 | my $port = shift; 11 | my $sock = IO::Socket::INET->new( 12 | PeerAddr => "localhost:$port", 13 | Proto => 'tcp', 14 | ); 15 | 16 | my $req = "GET / HTTP/1.1\015\012\015\012"; 17 | $sock->syswrite($req, length $req); 18 | 19 | my $resp = ""; 20 | while ($sock->sysread($resp, 65536, length $resp)) {} 21 | 22 | my $expected_interim = <<"EOT"; 23 | HTTP/1\.1 100 Continue\015 24 | foo: 123\015 25 | bar: 456\015 26 | \015 27 | EOT 28 | is substr($resp, 0, length $expected_interim), $expected_interim; 29 | like substr($resp, length $expected_interim), qr{^HTTP/1\.1 200 OK\015\012}is; 30 | }, 31 | server => sub { 32 | my $port = shift; 33 | my $loader = Plack::Loader->load('Starlet', port => $port); 34 | $loader->run(sub { 35 | my $env = shift; 36 | $env->{"psgix.informational"}->(100, [foo => 123, bar => 456]); 37 | [200, ['Content-Type' => 'text/plain'], ["OK"]]; 38 | }); 39 | exit; 40 | }, 41 | ); 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/15smuggling-content-length-and-transfer-encoding.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::TCP; 3 | use Plack::Test; 4 | use HTTP::Request; 5 | use HTTP::Message::PSGI; 6 | use Test::More; 7 | use Digest::MD5; 8 | use Plack::Test::Server; 9 | use Test::TCP; 10 | use IO::Socket::INET; 11 | 12 | $ENV{PLACK_SERVER} = 'Starlet'; 13 | 14 | my $app = sub { 15 | my $env = shift; 16 | my $body; 17 | my $clen = $env->{CONTENT_LENGTH}; 18 | while ($clen > 0) { 19 | $env->{'psgi.input'}->read(my $buf, $clen) or last; 20 | $clen -= length $buf; 21 | $body .= $buf; 22 | } 23 | return [ 200, [ 'Content-Type', 'text/plain', 'Content-Length', $env->{CONTENT_LENGTH} ], [ $body ] ]; 24 | }; 25 | 26 | my $server = Test::TCP->new( 27 | code => sub { 28 | my $sock_or_port = shift; 29 | my $server = Plack::Loader->auto( 30 | port => $sock_or_port, 31 | host => '127.0.0.1' 32 | ); 33 | $server->run($app); 34 | exit; 35 | }, 36 | ); 37 | 38 | my $sock = IO::Socket::INET->new( 39 | PeerAddr => '127.0.0.1', 40 | PeerPort => $server->port, 41 | Proto => 'tcp', 42 | ); 43 | 44 | print {$sock} ( 45 | "POST / HTTP/1.1\015\012" 46 | . "content-length: 12\015\012" 47 | . "Transfer-Encoding: chunked\015\012" 48 | . "\015\012" 49 | . "5\015\012" 50 | . "hello\015\012" 51 | . "0\015\012" 52 | . "\015\012" 53 | . "world" 54 | ); 55 | 56 | my $res_str = do { local $/; <$sock> }; 57 | like $res_str, qr{^HTTP/1\.1 200 .*\015\012\015\012hello$}s; 58 | 59 | done_testing; 60 | -------------------------------------------------------------------------------- /t/16smuggling-multiple-content-length-header.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::TCP; 3 | use Plack::Test; 4 | use HTTP::Request; 5 | use HTTP::Message::PSGI; 6 | use Test::More; 7 | use Digest::MD5; 8 | use Plack::Test::Server; 9 | use Test::TCP; 10 | use IO::Socket::INET; 11 | 12 | $ENV{PLACK_SERVER} = 'Starlet'; 13 | 14 | my $app = sub { 15 | my $env = shift; 16 | my $body; 17 | my $clen = $env->{CONTENT_LENGTH}; 18 | while ($clen > 0) { 19 | $env->{'psgi.input'}->read(my $buf, $clen) or last; 20 | $clen -= length $buf; 21 | $body .= $buf; 22 | } 23 | return [ 200, [ 'Content-Type', 'text/plain', 'X-Content-Length', $env->{CONTENT_LENGTH} ], [ $body ] ]; 24 | }; 25 | 26 | my $server = Test::TCP->new( 27 | code => sub { 28 | my $sock_or_port = shift; 29 | my $server = Plack::Loader->auto( 30 | port => $sock_or_port, 31 | host => '127.0.0.1' 32 | ); 33 | $server->run($app); 34 | exit; 35 | }, 36 | ); 37 | 38 | my $sock = IO::Socket::INET->new( 39 | PeerAddr => '127.0.0.1', 40 | PeerPort => $server->port, 41 | Proto => 'tcp', 42 | ); 43 | 44 | print {$sock} ( 45 | "GET / HTTP/1.1\015\012" 46 | . "content-length: 3\015\012" 47 | . "content-length: 9\015\012" 48 | . "connection: close\015\012" 49 | . "\015\012" 50 | . "123456789" 51 | ); 52 | 53 | my $res_str = do { local $/; <$sock> }; 54 | my ($status_line, ) = split /\015\012/, $res_str; 55 | is $status_line, 'HTTP/1.1 400 Bad Request'; 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/assets/baybridge.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kazuho/Starlet/f1f5dfbf70011287938b0b5fd7ac1117457676a2/t/assets/baybridge.jpg --------------------------------------------------------------------------------