File Coverage

lib/HTTP/Server/Connection.pm

Criterion	Covered	Total	%
statement	66	402	16.4
branch	0	164	0.0
condition	0	50	0.0
subroutine	22	61	36.0
pod	1	22	4.5
total	89	699	12.7

# Copyrights 2008 by Mark Overmeer.
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 1.05.
use strict;
use warnings;

package HTTP::Server::Connection;
use vars '$VERSION';
$VERSION = '0.11';


use HTTP::Server::Multiplex;
use HTTP::Server::Session;

use HTTP::Request    ();
use HTTP::Response   ();
use HTTP::Status;
use HTTP::Date       qw(time2str str2time);
use URI              ();
use LWP::MediaTypes  qw(guess_media_type);
use Fcntl            qw(O_RDONLY);
use Scalar::Util     qw(weaken);
use Socket           qw(unpack_sockaddr_in inet_ntoa);
use Storable         qw(freeze thaw);
use Fcntl            qw(:mode);
use POSIX            qw(strftime);

use Log::Report 'httpd-multiplex', syntax => 'SHORT';

use constant
 { HTTP_0_9 => 'HTTP/0.9'
 , HTTP_1_0 => 'HTTP/1.0'
 , HTTP_1_1 => 'HTTP/1.1'
 };

my @stat_fields =
   qw/dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks/;

my @default_headers;
sub setDefaultHeaders(@) {my $class = shift; push @default_headers, @_};

# oops, dirty hack
sub HTTP::Request::id() { shift->{HSC_id} }


my $conn_id = 'C0000000';

sub new($$$$)
{   my ($class, $mux, $fh, $daemon) = @_;
    my $self = bless {}, $class;
    $self->{HSC_requests} = [];
    $self->{HSC_mux}      = $mux;
    $self->{HSC_fh}       = $fh;
    $self->{HSC_session}  = HTTP::Server::Session->new;  # will change

    $self->{HSC_daemon}   = $daemon;
    weaken $self->{HSC_daemon};

    $self->{HSC_connect}  = time;
    $self->{HSC_conn_id}  = ++$conn_id;
    $self->{HSC_reqcount} = 0;

    my $peername          = $fh->peername;
    my ($port, $addr)     = unpack_sockaddr_in $peername;
    my $ip                = inet_ntoa $addr;
    info "$self->{HSC_conn_id} contacted by $ip:$port";

    my %client            = (port => $port, ip => $ip, host => undef);
    $daemon->dnslookup($self, $ip, \$client{host});
    $self->{HSC_client}   = \%client;

    $self;
}

sub client()  {shift->{HSC_client}}
sub session() {shift->{HSC_session}}
sub id()      {shift->{HSC_conn_id}}

# new text was received.  Collect it into an HTTP::Request
sub mux_input($$$)
{   my ($self, $mux, $fh, $refdata) = @_;
    my $req = $self->{HSC_next};

    # ignore input for closing, connection can still be writing
    if(!$req && $self->{HSC_no_more})
    {   $$refdata = '';
        return;
    }

    my $headers;
    if($req)
    {   $headers  = $req->headers;
    }
    else
    {   $$refdata =~ s/^\s+//s;                     # strip leading blanks
        $$refdata =~ s/(.*?)\r\n\r\n//s or return;  # not whole header yet
        $req  = $self->{HSC_next} = HTTP::Request->parse($1);
        $req->{HSC_id}
           = $self->{HSC_conn_id} . sprintf('-%02d', $self->{HSC_reqcount}++);

        my $proto = $req->protocol;
        $req->protocol($proto = HTTP_0_9)
            unless $proto;

        $headers  = $req->headers;
        $self->{HSC_no_more}++
            if $req->protocol lt HTTP_1_1
            || lc($headers->header('Connection') || '') ne 'keep-alive';

        if($proto lt HTTP_1_0)
        {   $self->{take_all}++;
            return;
        }

        if(my $expect = $headers->header('Expect'))
        {   if(lc $expect ne '100-continue')
            {   my $resp = $self->sendStatus($req, RC_EXPECTATION_FAILED);
                trace "Unsupported Expect value '$expect'";
                $self->cancelConnection;
                return $resp;
            }
            $self->sendStatus($req, RC_CONTINUE);
        }
    }

    my $te = lc($headers->header('Transfer-Encoding') || '');
    my $cl = $headers->header('Content-Length') || 0;

    if($te eq 'chunked')
    {   my ($starter, $len) = $$refdata =~ m/^((\S+)\r?\n)/ or return;
        if($len !~ m/^[0-9a-fA-F]+$/)
        {   my $resp = $self->sendStatus($req, RC_BAD_REQUEST);
            trace "Bad chunk header $len";
            $self->cancelConnection;
            return $resp;
        }
        my $need = hex $len;

        my $chunk_length = length($starter) + $need + 2;
        return if length($$refdata) < $chunk_length;

        if($need!=0)
        {   $req->add_content(substr $$refdata, length($starter), $need);
            substr($$refdata, 0, $chunk_length) = '';
            return;  # get more chunks
        }

        return if $$refdata !~ m/\n\r?\n/;  # need footer
        my ($footer) = $$refdata =~ s/^0+\r?\n(.*?\r?\n)\r?\n//;
        my $header   = $req->headers;
        HTTP::Message->parse($footer)->headers
                     ->scan(sub { $header->push_header(@_)} );

        $header->_header('Content-Length' => length ${$req->content_ref});
        $header->remove_header('Transfer-Encoding');
    }
    elsif($te ne '')
    {   my $resp = $self->sendStatus($req, RC_NOT_IMPLEMENTED);
        trace "Unsupported transfer encoding $te";
        $self->cancelConnection;
        return $resp;
    }
    elsif(defined $cl)
    {   return if defined $cl && length($$refdata) < $cl;
        $req->content(substr $$refdata, 0, $cl, '');
    }
    elsif(($headers->header('Content-Type') || '')
            =~ m/^multipart\/\w+\s*;.*boundary\s*=(["']?)\s*(\w+)\1/i)
    {   return unless $$refdata =~ s/(.*?\r?\n--\Q$2\E--\r?\n)//;
        $req->content($1);
    }
    else
    {   $self->closeConnection;
        $self->{take_all}++;
        # collect till eof
    }

    $mux->shutdown($fh, 0)
        if $self->{HSC_no_more};

    info $req->id.' '.$req->protocol.' '.$req->method.' '.$req->uri;
    if($self->{HSC_reqcount}==1)
    {   my $ua = $req->headers->header('User-Agent');
        info $req->id.' UA='.$ua   if $ua;
    }

    $self->addRequest(delete $self->{HSC_next});
}

sub mux_eof($$$)
{   my ($self, $mux, $fh, $refdata) = @_;

    my $req = delete $self->{HSC_next};
    if($req && length($$refdata) && $self->{take_all})
    {   $req->content_ref($refdata);
        $self->addRequest($req);
    }
    elsif($$refdata =~ m/\S/)
    {   trace "trailing data in request (".length($$refdata)." bytes) ignored";
    }

    $mux->shutdown($fh, 1);
}

# This is the most tricky part: each connection may have multiple
# requests queued.  If the handler returns a response object, the
# the response succeeded.  Otherwise, other IO will need to be performed:
# we simply stop.  When the other IO has completed, it will call this
# function again, to resolve the other requests.

sub addRequest($)
{   my ($self, $req) = @_;
    my $queue = $self->{HSC_requests};
    push @$queue, $req;

    # handler initiated by first request in queue, then auto-continues
    $self->handleRequests
        if @$queue==1;
}

sub handleRequests()
{   my ($self) = @_;
    my $queue  = $self->{HSC_requests};

  REQUEST:
    while(@$queue)
    {   my $req = shift @$queue;
        my $vhostn  = $req->header('Host');
        $vhostn     =~ s/\:(\d+)$//;   # strip optional port; ignored for now

        if(!defined $vhostn)
        {   if($req->protocol gt HTTP_1_1)
            {   $self->sendStatus($req, RC_MULTIPLE_CHOICES,
                "explicit virtual host required in protocol ".$req->protocol);
                next REQUEST;
            }
            $vhostn = 'default';
        }

        my $vhost   = $self->{HSC_daemon}->virtualHost($vhostn);
        unless(defined $vhost)
        {   $self->sendStatus($req, RC_NOT_FOUND, "no virtual host $vhostn");
            next REQUEST;
        }

        my $resp = $vhost->handleRequest($self, $req);
        defined $resp
            or last REQUEST;  # no answer==waiting in MUX
    }
}


sub sendResponse($$$;$)
{   my ($self, $req, $status, $header, $content) = @_;
    my $protocol = $req->protocol;
    defined $content or $content = '';

    if($protocol ge HTTP_1_0)
    {   push @$header
          , Date       => time2str(time)
          , Connection => ($self->{HSC_no_more} ? 'close' : 'keep-alive')
          , @default_headers;

        push @$header
          , ref $content eq 'CODE'
            ? ('Transfer-Encoding' => 'chunked')
            : ('Content-Length'    => length $content);
    }
    else
    {   undef $header;
    }

    my $resp = HTTP::Response->new($status, status_message($status),$header);
    $resp->request($req);
    $resp->protocol($protocol);

    my ($mux, $fh) = @$self{'HSC_mux', 'HSC_fh'};
    my $headtxt = $resp->as_string("\r\n");
    my $size    = length $headtxt;
    if($req->method eq 'HEAD')
    {   $mux->write($fh, $headtxt);
    }
    elsif(ref $content eq 'CODE')
    {   # create chunked
        $mux->write($fh, $headtxt);
        $size = 0;
        while(1)
        {   my $chunk = $content->();
            defined $chunk or last;
            length  $chunk or next;
            my $hexlen = sprintf "%x", length $chunk;
            $mux->write($fh, "$hexlen\r\n$chunk\r\n");
            $size     += length($hexlen) + length($chunk) + 4;
        }
        $mux->write($fh, "0\r\n\r\n");   # end chunks and no footer
        $size += 5;
    }
    else
    {   $resp->content_ref(\$content);
        $mux->write($fh, $headtxt.$content);
    }

    info $req->id." $status ${size}b";
    $resp;
}


sub sendStatus($$;$)
{   my ($self, $req, $status, $text) = @_;
    my $descr   = defined $text && length $text ? "\n$text" : '';
    my @headers = ('Content-Type' => 'text/html');
    my $message = status_message $status;

    $self->sendResponse($req, $status, \@headers, <<__CONTENT);
$status $message
$status $message$descr

__CONTENT
}


sub sendRedirect($$$;$)
{   my ($self, $req, $status, $location, $content) = @_;
    is_redirect $status
        or panic "Status '$status' is not redirect";

    my @headers = (Location => $location);
    if(defined $content && length $content)
    {   my $ct  = $content =~ m/^\s*\
        push @headers, 'Content-Type' => $ct;
    }

    $self->sendResponse($req, $status, \@headers, $content);
}


sub sendFile($$;$$)
{   my ($self, $req, $file, $headers, $user_callback) = @_;
    $user_callback ||= sub {};
    my ($callback, @headers);
    push @headers, @$headers if $headers;

    my $from_fh;
    if(ref $file)
    {   $from_fh = $file;
        $callback = sub
          { $user_callback->(@_);
            $self->handleRequests;
          };
    }
    else
    {   -e $file or return
            $self->sendStatus(RC_NOT_FOUND, "file $file does not exist");

        -f _ or return
            $self->sendStatus(RC_NOT_ACCEPTABLE, "not a file $file");

        sysopen $from_fh, $file, O_RDONLY
            or return $self->sendStatus(RC_FORBIDDEN, "no access to $file");

        $callback = sub
          { $user_callback->(@_);
            close $from_fh;  # read errors are ignored
            $self->handleRequests;
          };

        my ($ct, $ce) = guess_media_type $file;
        push @headers
          , Date       => time2str(time)
          , Connection => ($self->{HSC_no_more} ? 'close' : 'keep-alive')
          , @default_headers
          , 'Content-Type' => $ct;
        push @headers, 'Content-Encoding' => $ce if $ce;
    }

    my ($size, $mtime) = (stat $from_fh)[7,9];
    push @headers, 'Content-Length' => $size if $size;

    my $status = RC_OK;
    if($mtime)
    {   if(my $ims = $req->header('If-Modified-Since'))
        {   my $imstime = str2time $ims;
            $status     = RC_NOT_MODIFIED if $mtime==$imstime;
        }
        push @headers, 'Last-Modified' => time2str($mtime);
    }

    my $resp = HTTP::Response
        ->new($status, status_message($status), \@headers);

    $resp->request($req);
    $resp->protocol($req->protocol);

    my ($mux, $clientfh) = @$self{'HSC_mux', 'HSC_fh'};
    $mux->write($clientfh, $resp->as_string("\r\n"));

    if($req->method eq 'HEAD')
    {   info $req->id." sent head of $file";
        return $resp;
    }
    if($status==RC_NOT_MODIFIED)
    {   info $req->id." file $file was not modified";
        return $resp;
    }

    info $req->id." sent file $file, ${size}b";

    my $pump = _PUMP::PROXY->new($clientfh, $callback);
    $mux->add($from_fh);
    $mux->set_callback_object($pump, $from_fh);
    undef;
}


sub cancelConnection()
{   my $self = shift;
    info $self->id.' connection cancelled';
    delete @$self{'HSC_next', 'HSC_requests'};
    $self->closeConnection;
}


sub closeConnection()
{   my $self = shift;
    info $self->id.' connection closed';
    $self->{HSC_no_more}++;
}


my %filetype =
  ( &S_IFSOCK => 's', &S_IFLNK => 'l', &S_IFREG => '-', &S_IFBLK => 'b'
  , &S_IFDIR  => 'd', &S_IFCHR => 'c', &S_IFIFO => 'p');

my @flags    = ('---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx');

sub directoryList($$$@)
{   my ($self, $req, $dirname, $callback, %opts) = @_;

    trace $self->id. " listing of directory $dirname";
    opendir my $from_dir, $dirname
        or return $self->sendStatus($req, RC_FORBIDDEN);

    my $names      = $opts{names} || qr/^[^.]/;
    my $prefilter
       = ref $names eq 'Regexp' ? sub { $_[0] =~ $names }
       : ref $names eq 'CODE'   ? $names
       : panic "directoryList(names) must be regexp or code, not $names";

    my $postfilter = $opts{filter} || sub {1};
    ref $postfilter eq 'CODE'
        or panic "directoryList(filter) must be code, not $postfilter";

    my $hide_symlinks = $opts{hide_symlinks};

    my $run_async = sub
      { my (%dirlist, %users, %groups);
        foreach my $name (grep {$prefilter->($_)} readdir $from_dir)
        {   my $path = $dirname.$name;
            my %d = (name => $name, path => $path);
            @d{@stat_fields}
                = $hide_symlinks ? stat($path) : lstat($path);

               if(!$hide_symlinks && -l _)
                        { @d{qw/kind is_symlink  /} = ('SYMLINK',  1)}
            elsif(-d _) { @d{qw/kind is_directory/} = ('DIRECTORY',1)}
            elsif(-f _) { @d{qw/kind is_file     /} = ('FILE',     1)}
            else        { @d{qw/kind is_other    /} = ('OTHER',    1)}

            $postfilter->(\%d)
                or next;

            if($d{is_symlink})
            {   my $sl = $d{symlink_dest} = readlink $path;
                $d{symlink_dest_exists} = -e $sl;
            }
            elsif($d{is_file})
            {   my ($s, $l) = ($d{size}, '  ');
                ($s,$l) = ($s/1024, 'kB') if $s > 1024;
                ($s,$l) = ($s/1024, 'MB') if $s > 1024;
                ($s,$l) = ($s/1024, 'GB') if $s > 1024;
                $d{size_nice} = sprintf +($s>=100?"%.0f%s":"%.1f%s"), $s,$l;
            }
            elsif($d{is_directory})
            {   $d{name} .= '/';
            }

            if($d{is_file} || $d{is_directory})
            {   $d{user}  = $users{$d{uid}} ||= getpwuid $d{uid};
                $d{group} = $users{$d{gid}} ||= getgrgid $d{gid};
                my $mode = $d{mode};
                my $b = $filetype{$mode & S_IFMT} || '?';
                $b   .= $flags[ ($mode & S_IRWXU) >> 6 ];
                substr($b, -1, -1) = 's' if $mode & S_ISUID;
                $b   .= $flags[ ($mode & S_IRWXG) >> 3 ];
                substr($b, -1, -1) = 's' if $mode & S_ISGID;
                $b   .= $flags[  $mode & S_IRWXO ];
                substr($b, -1, -1) = 't' if $mode & S_ISVTX;
                $d{flags}      = $b;
                $d{mtime_nice} = strftime "%F %T", localtime $d{mtime};
            }
            $dirlist{$name} = \%d;
        }
        \%dirlist;
      };

    $self->async($req, $run_async, $callback);
    undef;
}


sub async
{   my ($self, $req, $run, $after) = @_;

    my ($reader, $writer);
    unless(pipe $reader, $writer)
    {   $self->sendStatus($req, RC_INTERNAL_SERVER_ERROR, "pipe: $!");
        return 0;
    }

    my $pid = fork;
    unless(defined $pid)
    {   trace "failed to fork: $!";
        $self->sendStatus($req, RC_INTERNAL_SERVER_ERROR, "fork: $!");
        return 0;
    }

    if($pid==0)  # child
    {   close $reader;
        my %data;
        $data{user} = [ $run->() ];
        $writer->print(freeze \%data);
        exit 0;
    }

    # parent
    close $writer;

    my $mux = $self->{HSC_mux};
    $mux->add($reader);
    my $callback = sub
      { my $data = eval { thaw ${$_[0]} };
        $mux->remove($reader);
        waitpid $pid, 0;   # need to check return
        $after->(@{$data->{user}});
        $self->handleRequests;
      };

    $mux->set_callback_object(_PUMP::READFILE->new($callback), $reader);
    1;
}


sub load($$)
{   my ($self, $file, $cb) = @_;
    my ($f, $callback);

    if(ref $file)
    {   ($f, $callback) = ($file, $cb);
    }
    else
    {   open $f, '<', $file
            or return $cb->(undef);

        trace "reading file $file";
        $callback = sub
          { close $f;
            $cb->($_[0]);
          };
    }

    my $mux = $self->{HSC_mux};
    $mux->add($f);
    $mux->set_callback_object(_PUMP::READFILE->new($callback), $f);
    undef;
}

sub readFile(@) {die "readFile() renamed to load() in 0.11"}


sub save($$$)
{   my ($self, $file, $data, $cb) = @_;
    my ($f, $callback);
    my $mux = $self->{HSC_mux};

    if(ref $file)
    {   ($f, $callback) = ($f, $cb);
    }
    else
    {   # IO::Multiplex is not able to deal with write-only file-handles,
        # Therefore '+>' i.s.o. simply '>' rt.cpan.org#39131
        open $f, '+>', $file
            or return $cb->(undef);

        trace "writing file $file";
        $callback = sub
          { close $f;
            $mux->remove($f);
            $cb->(@_);
          };
    }

    $mux->add($f);
    $mux->set_callback_object(_PUMP::WRITEFILE->new($callback), $f);
    $mux->write($f, ref $data eq 'SCALAR' ? $$data : $data);
    undef;
}
sub writeFile(@) {die "writeFile() renamed to save() in 0.11"}

#------------------------


##### _PUMP::PROXY
# Copy from incoming file-handle to out-going filehandle.

package _PUMP::PROXY;
use vars '$VERSION';
$VERSION = '0.11';


# $class->new($outfh,$callback)
sub new($$) { my $class = shift; bless \@_, $class }

sub mux_input($$$)
{   my ($outfh, $mux, $refdata) = ($_[0][0], $_[1], $_[3]);
    $mux->write($outfh, $$refdata);
    $$refdata = '';
}

sub mux_close() { shift->[1]->() }

##### _PUMP::READFILE
# Copy from incoming file-handle into a variable

package _PUMP::READFILE;
use vars '$VERSION';
$VERSION = '0.11';


# $class->new($callback)
sub new($) { my $class = shift; bless \@_, $class }

sub mux_eof($$$$)
{   my ($self, $mux, $fh, $refdata) = @_;
    $self->[0]->($refdata);
}

##### _PUMP::WRITEFILE
# Copy data to a file, and then call the callback

package _PUMP::WRITEFILE;
use vars '$VERSION';
$VERSION = '0.11';


# $class->new($callback)
sub new($) { my $class = shift; bless \@_, $class }

sub mux_eof($$)
{   my ($self, $mux, $fh) = @_;
    $self->[0]->();
}

1;