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 ( defined($nread) && length($buf) ) {
 125
 126                     $select->remove($client);
 127                     $client->close;
 128
 129                     next;
 130                 }
 131
 132                 $client->request_buffer .= $buf;
 133
 134                 if ( my $request = $client->get_request ) {
 135                     $client->request   = $request;
 136                     $client->timestamp = time
 137                 }
 138             }
 139         }
 140
 141         for my $client ( $select->handles ) {
 142
 143             next if $client == $daemon;
 144
 145             if ( ( time - $client->timestamp ) > 60 ) {
 146
 147                 $select->remove($client);
 148                 $client->close;
 149
 150                 next;
 151             }
 152
 153             next if $client->response;
 154             next unless $client->request;
 155
 156             $client->response = HTTP::Response->new;
 157             $client->response->protocol( $client->request->protocol );
 158
 159             $class->handler( $client->request, $client->response, $client );
 160         }
 161
 162         for my $client ( $select->can_write(0.01) ) {
 163
 164             next unless $client->response;
 165
 166             unless ( $client->response_buffer ) {
 167
 168                 my $connection = $client->request->header('Connection');
 169
 170                 if ( $connection && $connection =~ /Keep-Alive/i ) {
 171                     $client->response->header( 'Connection' => 'Keep-Alive' );
 172                     $client->response->header( 'Keep-Alive' => 'timeout=60, max=100' );
 173                 }
 174
 175                 $client->response_buffer = $client->response->as_string;
 176                 $client->response_offset = 0;
 177             }
 178
 179             my $nwrite = $client->syswrite( $client->response_buffer,
 180                                             $client->response_length,
 181                                             $client->response_offset );
 182
 183             unless ( defined($nwrite) ) {
 184
 185                 $select->remove($client);
 186                 $client->close;
 187
 188                 next;
 189             }
 190
 191             $client->response_offset += $nwrite;
 192
 193             if ( $client->response_offset == $client->response_length ) {
 194
 195                 my $connection = $client->request->header('Connection');
 196
 197                 unless ( $connection && $connection =~ /Keep-Alive/i ) {
 198                     $select->remove($client);
 199                     $client->close;
 200                 }
 201
 202                 $client->response        = undef;
 203                 $client->request         = undef;
 204                 $client->response_buffer = undef;
 205             }
 206         }
 207     }
 208 }
 209
 210 =back
 211
 212 =head1 SEE ALSO
 213
 214 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
 215 L<HTTP::Daemon>.
 216
 217 =head1 AUTHOR
 218
 219 Sebastian Riedel, C<sri@cpan.org>
 220 Christian Hansen, C<ch@ngmedia.com>
 221
 222 =head1 COPYRIGHT
 223
 224 This program is free software, you can redistribute it and/or modify it under
 225 the same terms as Perl itself.
 226
 227 =cut
 228
 229 package Catalyst::Engine::HTTP::Daemon::Catalyst;
 230
 231 use strict;
 232 use base 'HTTP::Daemon';
 233
 234 sub accept {
 235     return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
 236 }
 237
 238 sub product_tokens {
 239     return "Catalyst/$Catalyst::VERSION";
 240 }
 241
 242 package Catalyst::Engine::HTTP::Daemon::Client;
 243
 244 use strict;
 245 use base 'HTTP::Daemon::ClientConn';
 246
 247 sub request : lvalue {
 248     my $self = shift;
 249     ${*$self}{'request'};
 250 }
 251
 252 sub request_buffer : lvalue {
 253     my $self = shift;
 254     ${*$self}{'httpd_rbuf'};
 255 }
 256
 257 sub response : lvalue {
 258     my $self = shift;
 259     ${*$self}{'response'};
 260 }
 261
 262 sub response_buffer : lvalue {
 263     my $self = shift;
 264     ${*$self}{'httpd_wbuf'};
 265 }
 266
 267 sub response_length {
 268     my $self = shift;
 269     return length( $self->response_buffer );
 270 }
 271
 272 sub response_offset : lvalue {
 273     my $self = shift;
 274     ${*$self}{'httpd_woffset'};
 275 }
 276
 277 sub timestamp : lvalue {
 278     my $self = shift;
 279     ${*$self}{'timestamp'};
 280 }
 281
 282 1;