lib/Catalyst/Engine/HTTP/Daemon.pm

   1 package Catalyst::Engine::HTTP::Daemon;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::HTTP::Base';
   5
   6 use Catalyst::Exception;
   7 use IO::Select;
   8 use IO::Socket;
   9
  10 BEGIN {
  11
  12     if ( $^O eq 'MSWin32' ) {
  13
  14         *EINTR       = sub { 10004 };
  15         *EINPROGRESS = sub { 10036 };
  16         *EWOULDBLOCK = sub { 10035 };
  17         *F_GETFL     = sub {     0 };
  18         *F_SETFL     = sub {     0 };
  19
  20         *IO::Socket::blocking = sub {
  21             my ( $self, $blocking ) = @_;
  22             my $nonblocking = $blocking ? 0 : 1;
  23             ioctl( $self, 0x8004667e, \$nonblocking );
  24         };
  25     }
  26
  27     else {
  28         Errno->require;
  29         Errno->import( qw[EWOULDBLOCK EINPROGRESS EINTR] );
  30     }
  31 }
  32
  33 =head1 NAME
  34
  35 Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine
  36
  37 =head1 SYNOPSIS
  38
  39 A script using the Catalyst::Engine::HTTP::Daemon module might look like:
  40
  41     #!/usr/bin/perl -w
  42
  43     BEGIN {  $ENV{CATALYST_ENGINE} = 'HTTP::Daemon' }
  44
  45     use strict;
  46     use lib '/path/to/MyApp/lib';
  47     use MyApp;
  48
  49     MyApp->run;
  50
  51 =head1 DESCRIPTION
  52
  53 This is the Catalyst engine specialized for development and testing.
  54
  55 =head1 OVERLOADED METHODS
  56
  57 This class overloads some methods from C<Catalyst::Engine::HTTP::Base>.
  58
  59 =over 4
  60
  61 =item $c->handler
  62
  63 =cut
  64
  65 sub handler {
  66     my ( $class, $request, $response, $client ) = @_;
  67
  68     $request->uri->scheme('http');    # Force URI::http
  69     $request->uri->host( $request->header('Host') || $client->sockhost );
  70     $request->uri->port( $client->sockport );
  71
  72     my $http = Catalyst::Engine::HTTP::Base::struct->new(
  73         address  => $client->peerhost,
  74         request  => $request,
  75         response => $response
  76     );
  77
  78     $class->SUPER::handler($http);
  79 }
  80
  81 =item $c->run
  82
  83 =cut
  84
  85 sub run {
  86     my $class = shift;
  87     my $port  = shift || 3000;
  88
  89     $SIG{'PIPE'} = 'IGNORE';
  90
  91     my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new(
  92         Listen    => SOMAXCONN,
  93         LocalPort => $port,
  94         ReuseAddr => 1,
  95         Timeout   => 5
  96     );
  97
  98     unless ( defined $daemon ) {
  99
 100         Catalyst::Exception->throw(
 101             message => qq/Failed to create daemon. Reason: '$!'/
 102         );
 103     }
 104
 105     my $base = URI->new( $daemon->url )->canonical;
 106
 107     printf( "You can connect to your server at %s\n", $base );
 108
 109     my $select = IO::Select->new($daemon);
 110
 111     while (1) {
 112
 113         for my $client ( $select->can_read(0.01) ) {
 114
 115             if ( $client == $daemon ) {
 116                 $client = $daemon->accept;
 117                 $client->timestamp = time;
 118                 $client->blocking(0);
 119                 $select->add($client);
 120             }
 121
 122             else {
 123                 next if $client->request;
 124                 next if $client->response;
 125
 126                 my $nread = $client->sysread( my $buf, 4096 );
 127
 128                 unless ( $nread ) {
 129
 130                     next if $! == EWOULDBLOCK;
 131                     next if $! == EINPROGRESS;
 132                     next if $! == EINTR;
 133
 134                     $select->remove($client);
 135                     $client->close;
 136
 137                     next;
 138                 }
 139
 140                 $client->request_buffer .= $buf;
 141
 142                 if ( my $request = $client->get_request ) {
 143                     $client->request   = $request;
 144                     $client->timestamp = time
 145                 }
 146             }
 147         }
 148
 149         for my $client ( $select->handles ) {
 150
 151             next if $client == $daemon;
 152
 153             if ( ( time - $client->timestamp ) > 60 ) {
 154
 155                 $select->remove($client);
 156                 $client->close;
 157
 158                 next;
 159             }
 160
 161             next if $client->response;
 162             next unless $client->request;
 163
 164             $client->response = HTTP::Response->new;
 165             $client->response->protocol( $client->request->protocol );
 166
 167             $class->handler( $client->request, $client->response, $client );
 168         }
 169
 170         for my $client ( $select->can_write(0.01) ) {
 171
 172             next unless $client->response;
 173
 174             unless ( $client->response_buffer ) {
 175
 176                 $client->response->header( Server => $daemon->product_tokens );
 177
 178                 my $connection = $client->request->header('Connection') || '';
 179
 180                 if ( $connection =~ /Keep-Alive/i ) {
 181                     $client->response->header( 'Connection' => 'Keep-Alive' );
 182                     $client->response->header( 'Keep-Alive' => 'timeout=60, max=100' );
 183                 }
 184
 185                 if ( $connection =~ /close/i ) {
 186                     $client->response->header( 'Connection' => 'close' );
 187                 }
 188
 189                 $client->response_buffer = $client->response->as_string("\x0D\x0A");
 190                 $client->response_offset = 0;
 191             }
 192
 193             my $nwrite = $client->syswrite( $client->response_buffer,
 194                                             $client->response_length,
 195                                             $client->response_offset );
 196
 197             unless ( $nwrite ) {
 198
 199                 next if $! == EWOULDBLOCK;
 200                 next if $! == EINPROGRESS;
 201                 next if $! == EINTR;
 202
 203                 $select->remove($client);
 204                 $client->close;
 205
 206                 next;
 207             }
 208
 209             $client->response_offset += $nwrite;
 210
 211             if ( $client->response_offset == $client->response_length ) {
 212
 213                 my $connection = $client->request->header('Connection') || '';
 214                 my $protocol   = $client->request->protocol;
 215                 my $persistent = 0;
 216
 217                 if ( $protocol eq 'HTTP/1.1' && $connection !~ /close/i ) {
 218                     $persistent++;
 219                 }
 220
 221                 if ( $protocol ne 'HTTP/1.1' && $connection =~ /Keep-Alive/i ) {
 222                     $persistent++;
 223                 }
 224
 225                 unless ( $persistent ) {
 226                     $select->remove($client);
 227                     $client->close;
 228                 }
 229
 230                 $client->response        = undef;
 231                 $client->request         = undef;
 232                 $client->response_buffer = undef;
 233             }
 234         }
 235     }
 236 }
 237
 238 =back
 239
 240 =head1 SEE ALSO
 241
 242 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
 243 L<HTTP::Daemon>.
 244
 245 =head1 AUTHOR
 246
 247 Sebastian Riedel, C<sri@cpan.org>
 248 Christian Hansen, C<ch@ngmedia.com>
 249
 250 =head1 COPYRIGHT
 251
 252 This program is free software, you can redistribute it and/or modify it under
 253 the same terms as Perl itself.
 254
 255 =cut
 256
 257 package Catalyst::Engine::HTTP::Daemon::Catalyst;
 258
 259 use strict;
 260 use base 'HTTP::Daemon';
 261
 262 sub accept {
 263     return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
 264 }
 265
 266 sub product_tokens {
 267     return "Catalyst/$Catalyst::VERSION";
 268 }
 269
 270 package Catalyst::Engine::HTTP::Daemon::Client;
 271
 272 use strict;
 273 use base 'HTTP::Daemon::ClientConn';
 274
 275 sub request : lvalue {
 276     my $self = shift;
 277     ${*$self}{'request'};
 278 }
 279
 280 sub request_buffer : lvalue {
 281     my $self = shift;
 282     ${*$self}{'httpd_rbuf'};
 283 }
 284
 285 sub response : lvalue {
 286     my $self = shift;
 287     ${*$self}{'response'};
 288 }
 289
 290 sub response_buffer : lvalue {
 291     my $self = shift;
 292     ${*$self}{'httpd_wbuf'};
 293 }
 294
 295 sub response_length {
 296     my $self = shift;
 297     return length( $self->response_buffer );
 298 }
 299
 300 sub response_offset : lvalue {
 301     my $self = shift;
 302     ${*$self}{'httpd_woffset'};
 303 }
 304
 305 sub timestamp : lvalue {
 306     my $self = shift;
 307     ${*$self}{'timestamp'};
 308 }
 309
 310 1;