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