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