view release on metacpan or  search on metacpan

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

}

=head2 C<< $adapter->get_request() >>

Map a URL path to a filesystem path

Called in a loop from L<Contuinity>.

Returns the empty list on failure, which aborts the server process.
Aside from the constructor, this is the heart of this module.

This method is required for all adapters.

=cut

sub get_request {
  my ($self) = @_;

  # $self->Continuity::debug(2,__FILE__, ' ', __LINE__, "\n");
  while(1) {
    my $c = $self->daemon->accept or next;
    my $r = $c->get_request or next;
    return Continuity::Adapt::HttpDaemon::Request->new(
      debug_level => $self->debug_level,
      debug_callback => $self->debug_callback,
      conn => $c,
      http_request => $r,
      no_content_type => $self->no_content_type,
      cookies => '',
    );
  }
}

=head2 C<< $adapter->map_path($path) >>

Decodes URL-encoding in the path and attempts to guard against malice.
Returns the processed filesystem path.

=cut

sub map_path {
  my $self = shift;
  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};