view release on metacpan or  search on metacpan

lib/Continuity/Adapt/HttpDaemon.pm  view on Meta::CPAN

  my $path = shift() || '';
  my $docroot = $self->docroot || '';
  $docroot .= '/' if $docroot and $docroot ne '.' and $docroot !~ m{/$};
  # some massaging, also makes it more secure
  $path =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
  $path =~ s%//+%/%g unless $docroot;
  $path =~ s%/\.(?=/|$)%%g;
  $path =~ s%/[^/]+/\.\.(?=/|$)%%g;

  # if($path =~ m%^/?\.\.(?=/|$)%) then bad

$self->Continuity::debug(2,"path: $docroot$path\n");

  return "$docroot$path";
}

=head2 C<< $adapter->send_static($request) >>

Sends a static file off of the filesystem. The content-type is guessed by
HTTP::Daemon, plus we specifically tell it how to do png, css, and js.

This may be obvious, but you can't send binary data as part of the same request
that you've already sent text or HTML on, MIME aside. Thus either this is
called OR we invoke a continuation, but not both.

=cut

# HTTP::Daemon::send_file_response uses LWP::MediaTypes to guess the
# Content-Type of a file.  Unfortunately, its list of known extensions is
# rather anemic so we're adding a few more.
add_type('image/png'       => qw(png));
add_type('text/css'        => qw(css));
add_type('text/javascript' => qw(js));

sub send_static {
  my ($self, $r) = @_;
  my $c = $r->conn or die;
  my $url = $r->url;
  $url =~ s{\?.*}{};
  my $path = $self->map_path($url) or do { 
       $self->Continuity::debug(1, "can't map path: " . $url); $c->send_error(404); return; 
  };
  unless (-f $path) {
      $c->send_error(404);
      return;
  }
  $c->send_file_response($path);
  $self->Continuity::debug(3, "Static send '$path'");
}

package Continuity::Adapt::HttpDaemon::Request;

# Accessors

# List of cookies to send
sub cookies { exists $_[1] ? $_[0]->{cookies} = $_[1] : $_[0]->{cookies} }

# The actual connection
sub conn { exists $_[1] ? $_[0]->{conn} = $_[1] : $_[0]->{conn} }

# The HTTP::Request object
sub http_request { exists $_[1] ? $_[0]->{http_request} = $_[1] : $_[0]->{http_request} }

# Watch for writes to the conn
sub write_event { exists $_[1] ? $_[0]->{write_event} = $_[1] : $_[0]->{write_event} }

# Flag, never send type
sub no_content_type { exists $_[1] ? $_[0]->{no_content_type} = $_[1] : $_[0]->{no_content_type} }

# CGI query params
sub cached_params { exists $_[1] ? $_[0]->{cached_params} = $_[1] : $_[0]->{cached_params} }

sub debug_level { exists $_[1] ? $_[0]->{debug_level} = $_[1] : $_[0]->{debug_level} }

sub debug_callback { exists $_[1] ? $_[0]->{debug_callback} = $_[1] : $_[0]->{debug_callback} }

=for comment

See L<Continuity::Request> for API documentation.

This is what gets passed through a queue to coroutines when new requests for
them come in. It needs to encapsulate:

*  The connection filehandle
*  CGI parameters cache

XXX todo: understands GET parameters and POST in
application/x-www-form-urlencoded format, but not POST data in
multipart/form-data format.  Use the AsCGI thing if you actually really need
that (it's used for file uploads).
# XXX check request content-type, if it isn't x-form-data then throw an error
# XXX pass in multiple param names, get back multiple param values

Delegates requests off to the request object it was initialized from.

In other words: Continuity::Adapt::HttpDaemon is the ongoing running HttpDaemon
process, and Continuity::Adapt::HttpDaemon::Request is individual requests sent
through.

=cut

sub new {
    my $class = shift;
    my %args = @_;
    my $self = bless { @_ }, $class;
    eval { $self->conn->isa('HTTP::Daemon::ClientConn') } or warn "\$self->conn isn't an HTTP::Daemon::ClientConn";
    eval { $self->http_request->isa('HTTP::Request') } or warn "\$self->http_request isn't an HTTP::Request";
    $self->Continuity::debug(2, "\n====== Got new request ======\n"
               . "       Conn: ".$self->conn."\n"
               . "    Request: $self"
    );
    return $self;
}

sub param {
    my $self = shift; 
    my $req = $self->http_request;
    unless($self->cached_params) {
      $self->cached_params( do {
        my $in = $req->uri; $in .= '&' . $req->content if $req->content;
        $in =~ s{^.*\?}{};
        my @params;
        for(split/[&]/, $in) { 
            tr/+/ /; 
            s{%(..)}{pack('c',hex($1))}ge; 
            my($k, $v); ($k, $v) = m/(.*?)=(.*)/s or ($k, $v) = ($_, 1);
            push @params, $k, $v; 
        };
        \@params;
      });
    };
    my @params = @{ $self->cached_params };
    if(@_) {
        my @values;
        while(@_) {
          my $param = shift;
          for(my $i = 0; $i < @params; $i += 2) {
              push @values, $params[$i+1] if $params[$i] eq $param;
          }
        }
        return unless @values;
        return wantarray ? @values : $values[0];
    } else {
        return @{$self->cached_params};
    }
}

sub params {
    my $self = shift;
    $self->param;
    return @{$self->cached_params};
}

sub url_path {
  my $self = shift;
  my $path = $self->url->path;
  return $path;
}

sub end_request {
    my $self = shift;
    $self->write_event->cancel if $self->write_event;
    $self->conn->close if $self->conn;
}

sub set_cookie {
    my $self = shift;

lib/Continuity/Adapt/HttpDaemon.pm  view on Meta::CPAN

      $self->print(
           "Cache-Control: private, no-store, no-cache\r\n",
           "Pragma: no-cache\r\n",
           "Expires: 0\r\n",
           "Content-type: text/html\r\n",
           $cookies,
           "\r\n"
      );
    }
    1;
}

sub print { 
    my $self = shift; 
    $self->write_event(Coro::Event->io(fd => fileno $self->conn, poll => 'w', )) unless $self->write_event;
    my $e = $self->write_event;
    if(length $_[0] > 4096) {
        while(@_) { 
            my $x = shift;
            while(length $x > 4096) { $e->next; $self->conn->print(substr $x, 0, 4096, ''); }
            $e->next; $self->conn->print($x) 
        }
    } else {
        $e->next; $self->conn->print(@_); 
    }
    Coro::cede();
    return 1;
}

sub uri { $_[0]->http_request->uri(); }

sub method { $_[0]->http_request->method(); }

#
# end public Continuity::Request API methods
#

# sub query_string { $_[0]->{http_request}->query_string(); } # nope, doesn't exist in HTTP::Headers

sub immediate { }


# If we don't know how to do something, pass it on to the current http_request

sub AUTOLOAD {
  our $AUTOLOAD;
  my $method = $AUTOLOAD; $method =~ s/.*:://;
  return if $method eq 'DESTROY';
  my $self = shift;
  my $retval;
  if({peerhost=>1,send_basic_header=>1,'print'=>1,'send_redirect'=>1}->{$method}) {
    $retval = eval { $self->conn->$method(@_) };
    if($@) {
      warn "Continuity::Adapt::HttpDaemon::Request::AUTOLOAD: "
         . "Error calling conn method ``$method'', $@";
    }
  } else {
    $retval = eval { $self->http_request->$method(@_) };
    if($@) {
      warn "Continuity::Adapt::HttpDaemon::Request::AUTOLOAD: "
         . "Error calling HTTP::Request method ``$method'', $@";
    }
  }
  return $retval;
}

=head1 HTTP::Daemon Overrides

Although HTTP::Daemon is lovely, we have to patch it a bit to work correctly
with Coro. Fortunately there are only two things that much be touched, the
'accept' method and the _needs_more_data in HTTP::Daemon::ClientConn.

What we are doing is making these non-blocking using Coro::Event.

=cut

do {

    # HTTP::Daemon isn't Coro-friendly and attempting to diddle HTTP::Daemon's
    # inheritance to use Coro::Socket instead was a disaster.  So, instead, we
    # provide reimplementations of just a couple of functions to make it all
    # Coro-friendly.  This kind of meddling- under-the-hood is still just
    # asking for breaking from future versions of HTTP::Daemon.

    package HTTP::Daemon;
    use Errno;
    use Fcntl uc ':default';

    no warnings; # Don't warn for this override (this should be narrowed)
    sub accept {
        my $self = shift;
        my $pkg = shift || "HTTP::Daemon::ClientConn";  
        fcntl $self, &Fcntl::F_SETFL, &Fcntl::O_NONBLOCK or die "fcntl(O_NONBLOCK): $!";
        try_again:
        my ($sock, $peer) = $self->SUPER::accept($pkg);
        if($sock) {
            ${*$sock}{'httpd_daemon'} = $self;
            return wantarray ? ($sock, $peer) : $sock;
        } elsif($!{EAGAIN}) {
            my $socket_read_event = Coro::Event->io(fd => fileno $self, poll => 'r', ); # XXX should create this once per call rather than once per EGAIN
            $socket_read_event->next;
            $socket_read_event->cancel;
            goto try_again; 
        } else {
            return;
        }
    }

    package HTTP::Daemon::ClientConn;

    no warnings; # Don't warn for this override (this should be narrowed)

    sub _need_more {   
        my $self = shift;
        my $e = Coro::Event->io(fd => fileno $self, poll => 'r', $_[1] ? ( timeout => $_[1] ) : ( ), );
        $e->next;
        $e->cancel;
        my $n = sysread($self, $_[0], 2048, length($_[0]));
        $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
        $n;
    }