root/lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Interface/Standalone.pm @ 18235

Revision 18235, 7.3 kB (checked in by tokuhirom, 6 years ago)

WARNINGS

Line 
1package HTTP::Engine::Interface::Standalone;
2use HTTP::Engine::Interface
3    builder => 'NoEnv',
4    writer  => {
5        response_line => 1,
6        before => {
7            finalize => sub {
8                my($self, $req, $res) = @_;
9
10                $res->headers->date(time);
11
12                if ($req->_connection->{keepalive_available}) {
13                    $res->headers->header( Connection => 'keep-alive' );
14                } else {
15                    $res->headers->header( Connection => 'close' );
16                }
17            }
18        }
19    }
20;
21
22
23use Socket qw(:all);
24use IO::Socket::INET ();
25use IO::Select       ();
26
27BEGIN {
28    if ( $ENV{SMART_COMMENTS} ) {
29        Class::MOP::load_class('Smart::Comments');
30        Smart::Comments->import;
31    }
32}
33
34has host => (
35    is      => 'ro',
36    isa     => 'Str',
37    default => '127.0.0.1',
38);
39
40has port => (
41    is      => 'ro',
42    isa     => 'Int',
43    default => 1978,
44);
45
46has keepalive => (
47    is      => 'ro',
48    isa     => 'Bool',
49    default => 0,
50);
51
52has keepalive_timeout => (
53    is      => 'ro',
54    isa     => 'Int',
55    default => 5,
56);
57
58# fixme add preforking support using Parallel::Prefork
59has fork => (
60    is      => 'ro',
61    isa     => 'Bool',
62    default => 0,
63);
64
65has allowed => (
66    is      => 'rw',
67    isa     => 'HashRef',
68    default => sub { { '127.0.0.1' => '255.255.255.255' } },
69);
70
71has argv => (
72    is      => 'ro',
73    isa     => 'ArrayRef',
74    default => sub { [] },
75);
76
77no Moose;
78
79sub run {
80    my ( $self ) = @_;
81
82    if ($self->keepalive && !$self->fork) {
83        Carp::croak "set fork=1 if you want to work with keepalive!";
84    }
85
86    # Setup socket
87    my $daemon = IO::Socket::INET->new(
88        Listen    => SOMAXCONN,
89        LocalAddr => $self->host,
90        LocalPort => $self->port,
91        Proto     => 'tcp',
92        ReuseAddr => 1,
93        Type      => SOCK_STREAM,
94    ) or die "Couldn't create daemon: $!";
95
96    my $restart = 0;
97    my $parent = $$;
98    my $pid    = undef;
99    local $SIG{CHLD} = 'IGNORE';
100
101    ### start server
102    while (my ($remote, $peername) = $daemon->accept) {
103        ### accept : $remote->fileno
104        # TODO (Catalyst): get while ( my $remote = $daemon->accept ) to work
105        next unless my($method, $uri, $protocol) = $self->_parse_request_line($remote);
106        unless (uc $method eq 'RESTART') {
107            # Fork
108            next if $self->fork && ($pid = fork);
109            $self->_handler($remote, $method, $uri, $protocol, $peername);
110            if (defined $pid) {
111                $daemon->close;
112                exit();
113            }
114        } else {
115            ### RESTART
116            if ($self->_can_restart($peername)) {
117                $restart = 1;
118                last;
119            }
120        }
121    } continue {
122        close $remote;
123    }
124    $daemon->close;
125
126    if ($restart) {
127        $SIG{CHLD} = 'DEFAULT';
128        wait;
129        exec $^X, $0, @{ $self->argv };
130    }
131
132    exit;
133}
134
135sub _handler {
136    my($self, $remote, $method, $uri, $protocol, $peername) = @_;
137
138    # Ignore broken pipes as an HTTP server should
139    local $SIG{PIPE} = sub { close $remote };
140
141    # We better be careful and just use 1.0
142    $protocol = '1.0'; # XXX I don't know about why this needed.
143
144    my $select = IO::Select->new($remote);
145
146    $remote->autoflush(1);
147
148    while (1) {
149        # FIXME refactor an HTTP push parser
150
151        my $headers = $self->_parse_header($remote, $protocol);
152
153        my $connection = lc $headers->header("Connection");
154        ### connection: $connection
155
156        my $keepalive_available = $self->keepalive
157                                  && index( $connection, 'keep-alive' ) > -1
158        ;
159        ### keepalive_available: $keepalive_available
160
161        $self->_handle_one($remote, $method, $uri, $protocol, $peername, $headers, $keepalive_available);
162
163        if ($keepalive_available) {
164            ### waiting keepalive timeout
165            last unless $select->can_read($self->keepalive_timeout);
166
167            ### GO! keep alive!
168            last unless ($method, $uri, $protocol) = $self->_parse_request_line($remote, 1);
169        } else {
170            last;
171        }
172    }
173
174    $remote->read(my $buf, 4096) if $select->can_read(0); # IE hack
175
176    ### close connection
177    $remote->close();
178}
179
180sub _parse_request_line {
181    my($self, $handle, $is_keepalive) = @_;
182
183    # Parse request line
184    my $line = $self->_get_line($handle);
185    if ($is_keepalive && ($line eq '' || $line eq "\015")) {
186        $line = $self->_get_line($handle);
187    }
188    return ()
189      unless my($method, $uri, $protocol) =
190      $line =~ m/\A(\w+)\s+(\S+)(?:\s+HTTP\/(\d+(?:\.\d+)?))?\z/;
191    return ($method, $uri, $protocol);
192}
193
194sub _peeraddr {
195    my ($self, $peername) = @_;
196
197    my (undef, $iaddr) = sockaddr_in($peername);
198    return inet_ntoa($iaddr) || "127.0.0.1";
199}
200
201sub _get_line {
202    my($self, $handle) = @_;
203
204    # FIXME use bufferred but nonblocking IO? this is a lot of calls =(
205    my $line = '';
206    while ($handle->read(my $byte, 1)) {
207        last if $byte eq "\012";    # eol
208        $line .= $byte;
209    }
210
211    # strip \r, \n was already stripped
212    $line =~ s/\015$//s;
213
214    $line;
215}
216
217# Parse headers
218# taken from HTTP::Message, which is unfortunately not really reusable
219sub _parse_header {
220    my ($self, $remote, $protocol) = @_;
221
222    if ( $protocol >= 1 ) {
223        my @hdr;
224        while ( length( my $line = $self->_get_line($remote) ) ) {
225            if ( $line =~ s/^([^\s:]+)[ \t]*: ?(.*)// ) {
226                push( @hdr, $1, $2 );
227            }
228            elsif ( @hdr && $line =~ s/^([ \t].*)// ) {
229                $hdr[-1] .= "\n$1";
230            }
231            else {
232                last;
233            }
234        }
235        HTTP::Headers->new(@hdr);
236    }
237    else {
238        HTTP::Headers->new;
239    }
240}
241
242sub _handle_one {
243    my($self, $remote, $method, $uri, $protocol, $peername, $headers, $keepalive_available) = @_;
244
245    local *STDOUT = $remote;
246    $self->handle_request(
247        uri => URI::WithBase->new(
248            do {
249                my $u = URI->new($uri);
250                $u->scheme('http');
251                $u->host($headers->header('Host') || $self->host);
252                $u->port($self->port);
253                my $b = $u->clone;
254                $b->path_query('/');
255                ($u, $b);
256            },
257        ),
258        headers        => $headers,
259        _connection => {
260            input_handle        => $remote,
261            output_handle       => $remote,
262            env                 => {},
263            keepalive_available => $keepalive_available,
264        },
265        connection_info => {
266            method         => $method,
267            address        => $self->_peeraddr($peername),
268            port           => $self->port,
269            protocol       => "HTTP/$protocol",
270            user           => undef,
271            https_info     => undef,
272        },
273    );
274}
275
276sub _can_restart {
277    my ($self, $peername) = @_;
278
279    my $peeraddr = _inet_addr($self->_peeraddr($peername));
280    my $allowed = $self->allowed;
281    for my $ip (keys %{ $allowed }) {
282        my $mask = $allowed->{$ip};
283        if (($peeraddr & _inet_addr($mask)) == _inet_addr($ip)) {
284            return 1
285        }
286    }
287    return 0;
288}
289
290sub _inet_addr { unpack "N*", inet_aton($_[0]) }
291
292__INTERFACE__
293
294__END__
295
296=for stopwords Standalone
297
298=head1 NAME
299
300HTTP::Engine::Interface::Standalone - Standalone HTTP Server
301
302=head1 DESCRIPTION
303
304THIS MODULE WILL REMOVE!!
305
306=head1 AUTHOR
307
308Kazuhiro Osawa
309
Note: See TracBrowser for help on using the browser.