HTTP-Daemon-App version 0.0.9
============================

See
perldoc HTTP::Daemon::App
for POD

INSTALLATION

To install this module type the following:

  perl Makefile.PL
  make
  make test
  make install

DEPENDENCIES

  version
  HTTP::Daemon
  HTTP::Daemon::SSL
  HTTP::Status
  HTTP::Response
  Acme::Spork
  Unix::PID
  File::Spec

LARGE FILE SUPPORT ERRATA

Unfortunately $c->get_request() is bad for large files because it puts the in memory request into a buffer (also in memory) then once it has it a multi part parsed out puts that into the object. that can result in appx 3 times the amount of memory to upload a file than the file's size.

Below is a partial implementation using temp files that'd be exponentially more memory efficient. (especially for, say a webdav server when someone tries to upload a 300MB file (IE appx 90 MB of RAM for one request from one client, tisk tisk not good))

See TODO's below:

#### TODO: proper class for content and get_request use ##

my $orig_content = \&content;

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

   if (${*$self}{'content_is_fh'}){

       # TODO: do with ${*$self}{'content_fh'} what orig content does with buffer

       ${*$self}{'content_is_fh'} = 0;
       ${*$self}{'content_fh'}    = undef;

       unlink ${*$self}{'content_fh_path'};
       ${*$self}{'content_fh_path'} = undef;
   }
   else {
       $orig_content->(@_);
   }
}

# get_request() w/ tmpfile support instead of memory
sub get_request_large {
   my($self, $only_headers, $tmpfile) = @_;
   return $self->get_request($only_headers); # TODO: remove this line once all related TODOs are done

   if (${*$self}{'httpd_nomore'}) {
       $self->reason("No more requests from this connection");
       return;
   }

   $self->reason("");
   my $buf = ${*$self}{'httpd_rbuf'};
   $buf = "" unless defined $buf;

   my $timeout = $ {*$self}{'io_socket_timeout'};
   my $fdset = "";
   vec($fdset, $self->fileno, 1) = 1;
   local($_);

   READ_HEADER:
   while (1) {

       # loop until we have the whole header in $buf
       $buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
       if ($buf =~ /\012/) {  # potential, has at least one line
           if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
               if ($buf =~ /\015?\012\015?\012/) {
                   last READ_HEADER;  # we have it
               }
               elsif (length($buf) > 16*1024) {
                   $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
                   $self->reason("Very long header");
                   return;
               }
           }
           else {
               last READ_HEADER;  # HTTP/0.9 client
           }
       }
       elsif (length($buf) > 16*1024) {
           $self->send_error(414); # REQUEST_URI_TOO_LARGE
           $self->reason("Very long first line");
           return;
       }
       print STDERR "Need more data for complete header\n" if $DEBUG;
       return unless $self->_need_more($buf, $timeout, $fdset);
   }
   if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
       ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
       $self->send_error(400);  # BAD_REQUEST
       $self->reason("Bad request line: $buf");
       return;
   }
   my $method = $1;
   my $uri = $2;
   my $proto = $3 || "HTTP/0.9";
   $uri = "http://$uri" if $method eq "CONNECT";
   $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
   my $r = HTTP::Request->new($method, $uri);
   $r->protocol($proto);
   ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);

   if ($proto >= $HTTP_1_0) {

       # we expect to find some headers
       my($key, $val);
       HEADER:
       while ($buf =~ s/^([^\012]*)\012//) {
           $_ = $1;
           s/\015$//;
           if (/^([^:\s]+)\s*:\s*(.*)/) {
               $r->push_header($key, $val) if $key;
               ($key, $val) = ($1, $2);
           }
           elsif (/^\s+(.*)/) {
               $val .= " $1";
           }
           else {
               last HEADER;
           }
       }
       $r->push_header($key, $val) if $key;
   }

   my $conn = $r->header('Connection');
   if ($proto >= $HTTP_1_1) {
       ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
   }
   else {
       ${*$self}{'httpd_nomore'}++ unless $conn &&
         lc($conn) =~ /\bkeep-alive\b/;
   }

   if ($only_headers) {
       ${*$self}{'httpd_rbuf'} = $buf;
       return $r;
   }

   # Find out how much content to read
   my $te  = $r->header('Transfer-Encoding');
   my $ct  = $r->header('Content-Type');
   my $len = $r->header('Content-Length');

   if ($te && lc($te) eq 'chunked') {

       # Handle chunked transfer encoding
       my $body = "";
       CHUNK:
       while (1) {
           print STDERR "Chunked\n" if $DEBUG;
           if ($buf =~ s/^([^\012]*)\012//) {
               my $chunk_head = $1;
               unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
                   $self->send_error(400);
                   $self->reason("Bad chunk header $chunk_head");
                   return;
               }
               my $size = hex($1);
               last CHUNK if $size == 0;

               my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end

               # must read until we have a complete chunk
               while ($missing > 0) {
                   print STDERR "Need $missing more bytes\n" if $DEBUG;
                   my $n = $self->_need_more($buf, $timeout, $fdset);
                   return unless $n;
                   $missing -= $n;
               }
               $body .= substr($buf, 0, $size);
               substr($buf, 0, $size+2) = '';

           }
           else {

               # need more data in order to have a complete chunk header
               return unless $self->_need_more($buf, $timeout, $fdset);
           }
       }
       $r->content($body);

       # pretend it was a normal entity body
       $r->remove_header('Transfer-Encoding');
       $r->header('Content-Length', length($body));

       my($key, $val);
       FOOTER:
       while (1) {
           if ($buf !~ /\012/) {

               # need at least one line to look at
               return unless $self->_need_more($buf, $timeout, $fdset);
           }
           else {
               $buf =~ s/^([^\012]*)\012//;
               $_ = $1;
               s/\015$//;
               if (/^([\w\-]+)\s*:\s*(.*)/) {
                   $r->push_header($key, $val) if $key;
                   ($key, $val) = ($1, $2);
               }
               elsif (/^\s+(.*)/) {
                   $val .= " $1";
               }
               elsif (!length) {
                   last FOOTER;
               }
               else {
                   $self->reason("Bad footer syntax");
                   return;
               }
           }
       }
       $r->push_header($key, $val) if $key;

   }
   elsif ($te) {
       $self->send_error(501);         # Unknown transfer encoding
       $self->reason("Unknown transfer encoding '$te'");
       return;

   }
   elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {

       if($tmpfile && -w $tmpfile) {
           if(open ${*$self}{'content_fh'}, '<', $tmpfile) {
               ${*$self}{'content_is_fh'}   = 1;
               ${*$self}{'content_fh_path'} = $tmpfile;
           }
       }

       # TODO: if ${*$self}{'content_is_fh'} use it as $buf instead of memory

       # Handle multipart content type
       my $boundary = "$CRLF--$1--$CRLF";
       my $index;
       while (1) {
           $index = index($buf, $boundary);
           last if $index >= 0;

           # end marker not yet found
           return unless $self->_need_more($buf, $timeout, $fdset);
       }
       $index += length($boundary);
       $r->content(substr($buf, 0, $index));
       substr($buf, 0, $index) = '';

   }
   elsif ($len) {

       # Plain body specified by "Content-Length"
       my $missing = $len - length($buf);
       while ($missing > 0) {
           print "Need $missing more bytes of content\n" if $DEBUG;
           my $n = $self->_need_more($buf, $timeout, $fdset);
           return unless $n;
           $missing -= $n;
       }
       if (length($buf) > $len) {
           $r->content(substr($buf,0,$len));
           substr($buf, 0, $len) = '';
       }
       else {
           $r->content($buf);
           $buf='';
       }
   }
   ${*$self}{'httpd_rbuf'} = $buf;

   $r;
}


COPYRIGHT AND LICENCE

Put the correct copyright and licence information here.

Copyright (C) 2006 by Daniel Muey

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.