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