File Coverage

blib/lib/Net/Server/HTTP.pm

Criterion	Covered	Total	%
statement	220	409	53.7
branch	42	208	20.1
condition	22	94	23.4
subroutine	34	59	57.6
pod	30	40	75.0
total	348	810	42.9

# -*- perl -*-
#
#  Net::Server::HTTP - Extensible Perl HTTP base server
#
#  Copyright (C) 2010-2017
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
################################################################

package Net::Server::HTTP;

use strict;
use base qw(Net::Server::MultiType);
use Scalar::Util qw(weaken blessed);
use IO::Handle ();
use re 'taint'; # most of our regular expressions setting ENV should not be clearing taint
use POSIX ();
use Time::HiRes qw(time);
my $has_xs_parser;
BEGIN {$has_xs_parser = $ENV{'USE_XS_PARSER'} && eval { require HTTP::Parser::XS } };

sub net_server_type { __PACKAGE__ }

sub options {
    my $self = shift;
    my $ref  = $self->SUPER::options(@_);
    my $prop = $self->{'server'};
    $ref->{$_} = \$prop->{$_} for qw(timeout_header timeout_idle server_revision max_header_size
                                     access_log_format access_log_file enable_dispatch);
    return $ref;
}

sub timeout_header  { shift->{'server'}->{'timeout_header'}  }
sub timeout_idle    { shift->{'server'}->{'timeout_idle'}    }
sub server_revision { shift->{'server'}->{'server_revision'} }
sub max_header_size { shift->{'server'}->{'max_header_size'} }

sub default_port { 80 }

sub default_server_type { 'PreFork' }

sub initialize_logging {
    my $self = shift;
    $self->SUPER::initialize_logging(@_);
    my $prop = $self->{'server'};

    my $d = {
        access_log_format => '%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"',
    };
    $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d;

    $self->_init_access_log;
}

sub post_configure {
    my $self = shift;
    $self->SUPER::post_configure(@_);
    my $prop = $self->{'server'};

    # set other defaults
    my $d = {
        timeout_header  => 15,
        timeout_idle    => 60,
        server_revision => __PACKAGE__."/$Net::Server::VERSION",
        max_header_size => 100_000,
    };
    $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d;

    $self->_tie_client_stdout;
}

sub post_bind {
    my $self = shift;
    $self->SUPER::post_bind(@_);

    $self->_check_dispatch;
}

sub _init_access_log {
    my $self = shift;
    my $prop = $self->{'server'};
    my $log = $prop->{'access_log_file'};
    return if ! $log || $log eq '/dev/null';
    return if ! $prop->{'access_log_format'};
    $prop->{'access_log_format'} =~ s/\\([\\\"nt])/$1 eq 'n' ? "\n" : $1 eq 't' ? "\t" : $1/eg;
    if ($log eq 'STDOUT' || $log eq '/dev/stdout') {
        open my $fh, '>&', \*STDOUT or die "Could not dup STDOUT: $!";
        $fh->autoflush(1);
        $prop->{'access_log_function'} = sub { print $fh @_,"\n" };
    } elsif ($log eq 'STDERR' || $log eq '/dev/stderr') {
        $prop->{'access_log_function'} = sub { print STDERR @_,"\n" };
    } else {
        open my $fh, '>>', $log or die "Could not open access_log_file \"$log\": $!";
        $fh->autoflush(1);
        push @{ $prop->{'chown_files'} }, $log;
        $prop->{'access_log_function'} = sub { print $fh @_,"\n" };
    }
}

sub _tie_client_stdout {
    my $self = shift;
    my $prop = $self->{'server'};

    # install a callback that will handle our outbound header negotiation for the clients similar to what apache does for us
    my $copy = $self;
    $prop->{'tie_client_stdout'} = 1;
    $prop->{'tied_stdout_callback'} = sub {
        my $client = shift;
        my $method = shift;
        alarm($copy->timeout_idle); # reset timeout

        my $request_info = $copy->{'request_info'};
        if ($request_info->{'headers_sent'}) { # keep track of how much has been printed
            my ($resp, $len);
            if ($method eq 'print') {
                $resp = $client->print(my $str = join '', @_);
                $len = length $str;
            } elsif ($method eq 'printf') {
                $resp = $client->print(my $str = sprintf(shift, @_));
                $len = length $str;
            } elsif ($method eq 'say') {
                $resp = $client->print(my $str = join '', @_, "\n");
                $len = length $str;
            } elsif ($method eq 'write') {
                my $buf = shift;
                $buf = substr($buf, $_[1] || 0, $_[0]) if @_;
                $resp = $client->print($buf);
                $len = length $buf;
            } elsif ($method eq 'syswrite') {
                $len = $resp = $client->syswrite(@_);
            } else {
                return $client->$method(@_);
            }
            $request_info->{'response_size'} = ($request_info->{'response_size'} || 0) + $len if defined $len;
            return $resp;
        }

        die "All headers must only be sent via print ($method)\n" if $method ne 'print';

        my $headers = ${*$client}{'headers'} ||= {unparsed => '', parsed => ''};
        $headers->{'unparsed'} .= join('', @_);
        while ($headers->{'unparsed'} =~ s/^(.*?)\015?\012//) {
            my $line = $1;

            if (!$headers->{'parsed'} && $line =~ m{^HTTP/(1.[01]) \s+ (\d+) (?: | \s+ .+)$ }x) {
                $headers->{'status'} = [];
                $headers->{'parsed'} .= "$line\015\012";
                $prop->{'request_info'}->{'http_version'} = $1;
                $prop->{'request_info'}->{'response_status'} = $2;
            }
            elsif (! length $line) {
                my $s = $headers->{'status'} || die "Premature end of script headers\n";
                delete ${*$client}{'headers'};
                $copy->send_status(@$s) if @$s;
                $client->print($headers->{'parsed'}."\015\012");
                $request_info->{'headers_sent'} = 1;
                $request_info->{'response_header_size'} += length($headers->{'parsed'})+2;
                $request_info->{'response_size'} = length($headers->{'unparsed'});
                return $client->print($headers->{'unparsed'});
            } elsif ($line !~ s/^(\w+(?:-(?:\w+))*):\s*//) {
                my $invalid = ($line =~ /(.{0,120})/) ? "$1..." : '';
                $invalid =~ s/
                die "Premature end of script headers: $invalid\n";
            } else {
                my $key = "\u\L$1";
                $key =~ y/_/-/;
                push @{ $request_info->{'response_headers'} }, [$key, $line];
                if ($key eq 'Status' && $line =~ /^(\d+) (?:|\s+(.+?))$/ix) {
                    $headers->{'status'} = [$1, $2 || '-'];
                }
                elsif ($key eq 'Location') {
                    $headers->{'status'} = [302, 'bouncing'];
                }
                elsif ($key eq 'Content-type') {
                    $headers->{'status'} ||= [200, 'OK'];
                }
                $headers->{'parsed'} .= "$key: $line\015\012";
            }
        }
    };
    weaken $copy;
}

sub _check_dispatch {
    my $self = shift;
    if (! $self->{'server'}->{'enable_dispatch'}) {
        return if __PACKAGE__->can('process_request') ne $self->can('process_request');
        return if __PACKAGE__->can('process_http_request') ne $self->can('process_http_request');
    }

    my $app = $self->{'server'}->{'app'};
    if (! $app || (ref($app) eq 'ARRAY' && !@$app)) {
        $app = [];
        $self->configure({app => $app});
    }

    my %dispatch;
    my $first;
    my @dispatch;
    foreach my $a (ref($app) eq 'ARRAY' ? @$app : $app) {
        next if ! $a;
        my @pairs = ref($a) eq 'ARRAY' ? @$a
                  : ref($a) eq 'HASH'  ? %$a
                  : ref($a) eq 'CODE'  ? ('/', $a)
                  : $a =~ m{^(.+?)\s+(.+)$} ? ($1, $2)
                  : $a =~ m{^(.+?)=(.+)$}   ? ($1, $2)
                  : ($a, $a);
        for (my $i = 0; $i < @pairs; $i+=2) {
            my ($key, $val) = ("/$pairs[$i]", $pairs[$i+1]);
            $key =~ s{/\./}{/}g;
            $key =~ s{(?:/[^/]+|)/\../}{/}g;
            $key =~ s{//+}{/}g;
            if ($dispatch{$key}) {
                $self->log(2, "Already found a path matching \"$key\" - skipping.");
                next;
            }
            $dispatch{$key} = $val;
            push @dispatch, $key;
            $first ||= $key;
            $self->log(2, "  Dispatch: $key => $val");
        }
    }
    if (@dispatch) {
        if (! $dispatch{'/'} && $first) {
            $dispatch{'/'} = $dispatch{$first};
            push @dispatch, '/';
            $self->log(2, "  Dispatch: / => $dispatch{$first} (default)");
        }
        $self->{'dispatch_qr'} = join "|", map {"\Q$_\E"} @dispatch;
        $self->{'dispatch'} = \%dispatch;
    }
}

sub http_base_headers {
    my $self = shift;
    return [
        [Date => gmtime()." GMT"],
        [Connection => 'close'],
        [Server => $self->server_revision],
    ];
}

sub send_status {
    my ($self, $status, $msg, $body) = @_;
    $msg ||= ($status == 200) ? 'OK' : '-';
    my $request_info = $self->{'request_info'};

    my $out = "HTTP/1.0 $status $msg\015\012";
    foreach my $row (@{ $self->http_base_headers }) {
        $out .= "$row->[0]: $row->[1]\015\012";
        push @{ $request_info->{'response_headers'} }, $row;
    }
    $self->{'server'}->{'client'}->print($out);
    $request_info->{'http_version'} = '1.0';
    $request_info->{'response_status'} = $status;
    $request_info->{'response_header_size'} += length $out;

    if ($body) {
        push @{ $request_info->{'response_headers'} }, ['Content-type', 'text/html'];
        $out = "Content-type: text/html\015\012\015\012";
        $request_info->{'response_header_size'} += length $out;
        $self->{'server'}->{'client'}->print($out);
        $request_info->{'headers_sent'} = 1;
        $self->{'server'}->{'client'}->print($body);
        $request_info->{'response_size'} += length $body;
    }
}

sub send_500 {
    my ($self, $err) = @_;
    $self->send_status(500, 'Internal Server Error',
                       "Internal Server Error$err");
}

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

sub run_client_connection {
    my $self = shift;
    local $self->{'request_info'} = {};
    return $self->SUPER::run_client_connection(@_);
}

sub get_client_info {
    my $self = shift;
    $self->SUPER::get_client_info(@_);
    $self->clear_http_env;
}

sub clear_http_env {
    my $self = shift;
    %ENV = ();
}

sub process_request {
    my $self = shift;
    my $client = shift || $self->{'server'}->{'client'};

    my $ok = eval {
        local $SIG{'ALRM'} = sub { die "Server Timeout on headers\n" };
        alarm($self->timeout_header);
        $self->process_headers($client);

        $SIG{'ALRM'} = sub { die "Server Timeout on process\n" };
        alarm($self->timeout_idle);
        $self->process_http_request($client);

        alarm(0);
        1;
    };
    alarm(0);

    if (! $ok) {
        my $err = "$@" || "Something happened";
        $self->log(1, $err);
        $self->send_500($err);
    }
}

sub script_name { shift->{'script_name'} || '' }

sub process_headers {
    my $self = shift;
    my $client = shift || $self->{'server'}->{'client'};

    $ENV{'REMOTE_PORT'} = $self->{'server'}->{'peerport'};
    $ENV{'REMOTE_ADDR'} = $self->{'server'}->{'peeraddr'};
    $ENV{'SERVER_PORT'} = $self->{'server'}->{'sockport'};
    $ENV{'SERVER_ADDR'} = $self->{'server'}->{'sockaddr'};
    $ENV{'HTTPS'} = 'on' if $self->{'server'}->{'client'}->NS_proto =~ /SSL/;

    my ($ok, $headers) = $client->read_until($self->max_header_size, qr{\n\r?\n});
    my ($req, $len, @parsed);
    die "Could not parse http headers successfully\n" if $ok != 1;
    if ($has_xs_parser) {
        $len = HTTP::Parser::XS::parse_http_request($headers, \%ENV);
        die "Corrupt request" if $len == -1;
        die "Incomplete request" if $len == -2;
        $req = "$ENV{'REQUEST_METHOD'} $ENV{'REQUEST_URI'} $ENV{'SERVER_PROTOCOL'}";
    } else {
        ($req, my @lines) = split /\r?\n/, $headers;
        die "Missing request\n" if ! defined $req;

        if (!defined($req) || $req !~ m{ ^\s*(GET|POST|PUT|PATCH|DELETE|PUSH|HEAD|OPTIONS)\s+(.+)\s+(HTTP/1\.[01])\s*$ }ix) {
            die "Invalid request\n";
        }
        $ENV{'REQUEST_METHOD'}  = uc $1;
        $ENV{'REQUEST_URI'}     = $2;
        $ENV{'SERVER_PROTOCOL'} = $3;
        $ENV{'QUERY_STRING'}    = $1 if $ENV{'REQUEST_URI'} =~ m{ \?(.*)$ }x;
        $ENV{'PATH_INFO'}       = $1 if $ENV{'REQUEST_URI'} =~ m{^([^\?]+)};

        foreach my $l (@lines) {
            my ($key, $val) = split /\s*:\s*/, $l, 2;
            push @parsed, [$key, $val];
            $key = uc($key);
            $key = 'COOKIE' if $key eq 'COOKIES';
            $key =~ y/-/_/;
            $key =~ s/^\s+//;
            $key = "HTTP_$key" if $key !~ /^CONTENT_(?:LENGTH|TYPE)$/;
            $val =~ s/\s+$//;
            if (exists $ENV{$key}) {
                $ENV{$key} .= ", $val";
            } else {
                $ENV{$key} = $val;
            }
        }
        $len = length $headers;
    }
    $ENV{'SCRIPT_NAME'} = $self->script_name($ENV{'PATH_INFO'}) || '';

    my $type = $Net::Server::HTTP::ISA[0];
    $type = $Net::Server::MultiType::ISA[0] if $type eq 'Net::Server::MultiType';
    $ENV{'NET_SERVER_TYPE'} = $type;
    $ENV{'NET_SERVER_SOFTWARE'} = $self->server_revision;

    $self->_init_http_request_info($req, \@parsed, $len);
}

sub http_request_info { shift->{'request_info'} }

sub _init_http_request_info {
    my ($self, $req, $parsed, $len) = @_;
    my $prop = $self->{'server'};
    my $info = $self->{'request_info'};
    @$info{qw(sockaddr sockport peeraddr peerport)} = @$prop{qw(sockaddr sockport peeraddr peerport)};
    $info->{'peerhost'} = $prop->{'peerhost'} || $info->{'peeraddr'};
    $info->{'begin'} = time;
    $info->{'request'} = $req;
    $info->{'request_headers'} = $parsed;
    $info->{'query_string'} = "?$ENV{'QUERY_STRING'}" if defined $ENV{'QUERY_STRING'};
    $info->{'request_protocol'} = $ENV{'HTTPS'} ? 'https' : 'http';
    $info->{'request_method'} = $ENV{'REQUEST_METHOD'};
    $info->{'request_path'} = $ENV{'PATH_INFO'};
    $info->{'request_header_size'} = $len;
    $info->{'request_size'} = $ENV{'CONTENT_LENGTH'} || 0; # we might not actually read entire request
    $info->{'remote_user'} = '-';
}

sub http_note {
    my ($self, $key, $val) = @_;
    return $self->{'request_info'}->{'notes'}->{$key} = $val if @_ >= 3;
    return $self->{'request_info'}->{'notes'}->{$key};
}

sub http_dispatch {
    my ($self, $dispatch_qr, $dispatch_table) = @_;

    $ENV{'PATH_INFO'} =~ s{^($dispatch_qr)(?=/|$|(?<=/))}{} or die "Dispatch not found\n";
    $ENV{'SCRIPT_NAME'} = $1;
    if ($ENV{'PATH_INFO'}) {
        $ENV{'PATH_INFO'} = "/$ENV{'PATH_INFO'}" if $ENV{'PATH_INFO'} !~ m{^/};
        $ENV{'PATH_INFO'} =~ s/%([a-fA-F0-9]{2})/chr(hex $1)/eg;
    }
    my $code = $self->{'dispatch'}->{$1};
    return $self->$code() if ref $code;
    $self->exec_cgi($code);
}

sub process_http_request {
    my ($self, $client) = @_;

    if (my $table = $self->{'dispatch'}) {
        my $qr = $self->{'dispatch_qr'} or die "Dispatch was not correctly setup\n";
        return $self->http_dispatch($qr, $table)
    }

    return $self->http_echo;
}

sub http_echo {
    my $self = shift;
    print "Content-type: text/html\n\n";
    print "\n";
    if (eval { require Data::Dumper }) {
        local $Data::Dumper::Sortkeys = 1;
        my $form = {};
        if (eval { require CGI }) {  my $q = CGI->new; $form->{$_} = $q->param($_) for $q->param;  }
        print "".Data::Dumper->Dump([\%ENV, $form], ['*ENV', 'form'])."";
    }
}

sub post_process_request {
    my $self = shift;
    my $info = $self->{'request_info'};
    $info->{'begin'} = time unless defined $info->{'begin'};
    $info->{'elapsed'} = time - $info->{'begin'};
    $self->SUPER::post_process_request(@_);
    $self->log_http_request($info);
}

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

sub log_http_request {
    my ($self, $info) = @_;
    my $prop = $self->{'server'};
    my $fmt  = $prop->{'access_log_format'} || return;
    my $log  = $prop->{'access_log_function'} || return;
    $log->($self->http_log_format($fmt, $info));
}

my %fmt_map = qw(
    a peeraddr
    A sockaddr
    B response_size
    f filename
    h peerhost
    H request_protocol
    l remote_logname
    m request_method
    p sockport
    q query_string
    r request
    s response_status
    u remote_user
    U request_path
    );
my %fmt_code = qw(
    C http_log_cookie
    e http_log_env
    i http_log_header_in
    n http_log_note
    o http_log_header_out
    P http_log_pid
    t http_log_time
    v http_log_vhost
    V http_log_vhost
    X http_log_constat
);

sub http_log_format {
    my ($self, $fmt, $info, $orig) = @_;
    $fmt =~ s{ % ([<>])?                      # 1
                 (!? \d\d\d (?:,\d\d\d)* )?   # 2
                 (?: \{ ([^\}]+) \} )?        # 3
                 ([aABDfhHmpqrsTuUvVhblPtIOCeinoPtX%])  # 4
    }{
        $info = $orig if $1 && $orig && $1 eq '<';
        my $v = $2 && (substr($2,0,1) eq '!' ? index($2, $info->{'response_status'})!=-1 : index($2, $info->{'response_status'})==-1) ? '-'
              : $fmt_map{$4}  ? $info->{$fmt_map{$4}}
              : $fmt_code{$4} ? do { my $m = $fmt_code{$4}; $self->$m($info, $3, $1, $4) }
              : $4 eq 'b'     ? $info->{'response_size'} || '-' # B can be 0, b cannot
              : $4 eq 'I'     ? $info->{'request_size'} + $info->{'request_header_size'}
              : $4 eq 'O'     ? $info->{'response_size'} + $info->{'response_header_size'}
              : $4 eq 'T'     ? sprintf('%d', $info->{'elapsed'})
              : $4 eq 'D'     ? sprintf('%d', $info->{'elapsed'}/.000_001)
              : $4 eq '%'     ? '%'
              : '-';
        $v = '-' if !defined($v) || !length($v);
        $v =~ s/([^\ -\!\#-\[\]-\~])/$1 eq "\n" ? '\n' : $1 eq "\t" ? '\t' : sprintf('\x%02X', ord($1))/eg; # escape non-printable or " or \
        $v;
    }gxe;
    return $fmt;
}
sub http_log_time {
    my ($self, $info, $fmt) = @_;
    return '['.POSIX::strftime($fmt || '%d/%b/%Y:%T %z', localtime($info->{'begin'})).']';
}
sub http_log_env { $ENV{$_[2]} }
sub http_log_cookie {
    my ($self, $info, $var) = @_;
    my @c;
    for my $cookie (map {$_->[1]} grep {$_->[0] eq 'Cookie' } @{ $info->{'request_headers'} || [] }) {
        push @c, $1 if $cookie =~ /^\Q$var\E=(.*)/;
    }
    return join ', ', @c;
}
sub http_log_header_in {
    my ($self, $info, $var) = @_;
    return join ', ', map {$_->[1]} grep {$_->[0] eq $var} @{ $info->{'request_headers'} || [] };
}
sub http_log_note {
    my ($self, $info, $var) = @_;
    return $self->http_note($var);
}
sub http_log_header_out {
    my ($self, $info, $var) = @_;
    return join ', ', map {$_->[1]} grep {$_->[0] eq $var} @{ $info->{'response_headers'} || [] };
}
sub http_log_pid { $_[1]->{'pid'} || $$ } # we do not support tid yet
sub http_log_vhost {
    my ($self, $info, $fmt, $f_l, $type) = @_;
    return $self->http_log_header_in($info, 'Host') || $self->{'server'}->{'client'}->NS_host || $self->{'server'}->{'sockaddr'};
}
sub http_log_constat {
    my ($self, $info) = @_;
    return $info->{'headers_sent'} ? '-' : 'X';
}

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

sub exec_fork_hook {}

sub exec_trusted_perl {
    my ($self, $file) = @_;
    die "File $file is not executable\n" if ! -x $file;
    local $!;
    my $pid = fork;
    die "Could not spawn child process: $!\n" if ! defined $pid;
    $self->exec_fork_hook($pid, $file, 1);
    if (!$pid) {
        if (!eval { require $file }) {
            my $err = "$@" || "Error while running trusted perl script\n";
            $err =~ s{\s*Compilation failed in require at lib/Net/Server/HTTP\.pm line \d+\.\s*\z}{\n};
            die $err if !$self->{'request_info'}->{'headers_sent'};
            warn $err;
        }
        exit;
    } else {
        waitpid $pid, 0;
        return;
    }
}

sub exec_cgi {
    my ($self, $file) = @_;

    my $done = 0;
    my $pid;
    Net::Server::SIG::register_sig(CHLD => sub {
        while (defined(my $chld = waitpid(-1, POSIX::WNOHANG()))) {
            $done = ($? >> 8) || -1 if $pid == $chld;
            last unless $chld > 0;
        }
    });

    require IPC::Open3;
    require Symbol;
    my $in;
    my $out;
    my $err = Symbol::gensym();
    local $!;
    $pid = eval { IPC::Open3::open3($in, $out, $err, $file) } or die "Could not run external script $file: $!\n";
    $self->exec_fork_hook($pid, $file); # won't occur for the child
    my $len = $ENV{'CONTENT_LENGTH'} || 0;
    my $s_in  = $len ? IO::Select->new($in) : undef;
    my $s_out = IO::Select->new($out, $err);
    my $printed;
    while (!$done) {
        my ($o, $i, $e) = IO::Select->select($s_out, $s_in, undef);
        Net::Server::SIG::check_sigs();
        for my $fh (@$o) {
            read($fh, my $buf, 4096) || next;
            if ($fh == $out) {
                print $buf;
                $printed ||= 1;
            } else {
                print STDERR $buf;
            }
        }
        if (@$i) {
            my $bytes = read(STDIN, my $buf, $len);
            print $in $buf if $bytes;
            $len -= $bytes;
            $s_in = undef if $len <= 0;
        }
    }
    if (!$self->{'request_info'}->{'headers_sent'}) {
        if (!$printed) {
            $self->send_500("Premature end of script headers");
        } elsif ($done > 0) {
            $self->send_500("Script exited unsuccessfully");
        }
    }

    Net::Server::SIG::unregister_sig('CHLD');
}

1;

__END__