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.