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(1) ) {
 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(1) ) {
 162
 163             next unless $client->response;
 164
 165             unless ( $client->response_buffer ) {
 166                 $client->response_buffer = $client->response->as_string;
 167                 $client->response_offset = 0;
 168             }
 169
 170             my $nwrite = $client->syswrite( $client->response_buffer,
 171                                             $client->response_length,
 172                                             $client->response_offset );
 173
 174             unless ( defined($nwrite) ) {
 175
 176                 $select->remove($client);
 177                 $client->close;
 178
 179                 next;
 180             }
 181
 182             $client->response_offset += $nwrite;
 183
 184             if ( $client->response_offset == $client->response_length ) {
 185
 186                 my $connection = $client->request->header('Connection');
 187
 188                 unless ( $connection && $connection =~ /Keep-Alive/i ) {
 189                     $select->remove($client);
 190                     $client->close;
 191                 }
 192
 193                 $client->response        = undef;
 194                 $client->request         = undef;
 195                 $client->response_buffer = undef;
 196             }
 197         }
 198     }
 199 }
 200
 201 =back
 202
 203 =head1 SEE ALSO
 204
 205 L<Catalyst>, L<Catalyst::Engine>, L<Catalyst::Engine::HTTP::Base>,
 206 L<HTTP::Daemon>.
 207
 208 =head1 AUTHOR
 209
 210 Sebastian Riedel, C<sri@cpan.org>
 211 Christian Hansen, C<ch@ngmedia.com>
 212
 213 =head1 COPYRIGHT
 214
 215 This program is free software, you can redistribute it and/or modify it under
 216 the same terms as Perl itself.
 217
 218 =cut
 219
 220 package Catalyst::Engine::HTTP::Daemon::Catalyst;
 221
 222 use strict;
 223 use base 'HTTP::Daemon';
 224
 225 sub accept {
 226     return shift->SUPER::accept('Catalyst::Engine::HTTP::Daemon::Client');
 227 }
 228
 229 sub product_tokens {
 230     return "Catalyst/$Catalyst::VERSION";
 231 }
 232
 233 package Catalyst::Engine::HTTP::Daemon::Client;
 234
 235 use strict;
 236 use base 'HTTP::Daemon::ClientConn';
 237
 238 sub request : lvalue {
 239     my $self = shift;
 240     ${*$self}{'request'};
 241 }
 242
 243 sub request_buffer : lvalue {
 244     my $self = shift;
 245     ${*$self}{'httpd_rbuf'};
 246 }
 247
 248 sub response : lvalue {
 249     my $self = shift;
 250     ${*$self}{'response'};
 251 }
 252
 253 sub response_buffer : lvalue {
 254     my $self = shift;
 255     ${*$self}{'httpd_wbuf'};
 256 }
 257
 258 sub response_length {
 259     my $self = shift;
 260     return length( $self->response_buffer );
 261 }
 262
 263 sub response_offset : lvalue {
 264     my $self = shift;
 265     ${*$self}{'httpd_woffset'};
 266 }
 267
 268 sub timestamp : lvalue {
 269     my $self = shift;
 270     ${*$self}{'timestamp'};
 271 }
 272
 273 1;