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