view release on metacpan or  search on metacpan

lib/MHFS/HTTP/Server/Client/Request.pm  view on Meta::CPAN

package MHFS::HTTP::Server::Client::Request v0.7.0;
use 5.014;
use strict; use warnings;
use feature 'say';
use Time::HiRes qw( usleep clock_gettime CLOCK_REALTIME CLOCK_MONOTONIC);
use URI::Escape;
use Cwd qw(abs_path getcwd);
use Feature::Compat::Try;
use File::Basename;
use File::stat;
use IO::Poll qw(POLLIN POLLOUT POLLHUP);
use Data::Dumper;
use Scalar::Util qw(weaken);
use List::Util qw[min max];
use Symbol 'gensym';
use Devel::Peek;
use Encode qw(decode encode);
use constant {
    MAX_REQUEST_SIZE => 8192,
};
use FindBin;
use File::Spec;
use MHFS::EventLoop::Poll;
use MHFS::Process;
use MHFS::Util qw(get_printable_utf8 LOCK_GET_LOCKDATA getMIME shell_escape escape_html_noquote parse_ipv4);
BEGIN {
    if( ! (eval "use JSON; 1")) {
        eval "use JSON::PP; 1" or die "No implementation of JSON available";
        warn __PACKAGE__.": Using PurePerl version of JSON (JSON::PP)";
    }
}

# Optional dependency, Alien::Tar::Size
BEGIN {
    use constant HAS_Alien_Tar_Size => (eval "use Alien::Tar::Size; 1");
    if(! HAS_Alien_Tar_Size) {
        warn "Alien::Tar::Size is not available";
    }
}

sub new {
    my ($class, $client) = @_;
    my %self = ( 'client' => $client);
    bless \%self, $class;
    weaken($self{'client'}); #don't allow Request to keep client alive
    $self{'on_read_ready'} = \&want_request_line;
    $self{'outheaders'}{'X-MHFS-CONN-ID'} = $client->{'outheaders'}{'X-MHFS-CONN-ID'};
    $self{'rl'} = 0;
    # we want the request
    $client->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
    $self{'recvrequesttimerid'} = $client->AddClientCloseTimer($client->{'server'}{'settings'}{'recvrequestimeout'}, $client->{'CONN-ID'}, 1);
    return \%self;
}

# on ready ready handlers
sub want_request_line {
    my ($self) = @_;

    my $ipos = index($self->{'client'}{'inbuf'}, "\r\n");
    if($ipos != -1) {
        if(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^\s]+)\s+([^\s]+)\s+(?:HTTP\/1\.([0-1])))\r\n/) {
            my $rl = $1;
            $self->{'method'}    = $2;
            $self->{'uri'}       = $3;
            $self->{'httpproto'} = $4;
            my $rid = int(clock_gettime(CLOCK_MONOTONIC) * rand()); # insecure uid
            $self->{'outheaders'}{'X-MHFS-REQUEST-ID'} = sprintf("%X", $rid);
            say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . " X-MHFS-REQUEST-ID: " . $self->{'outheaders'}{'X-MHFS-REQUEST-ID'};
            say "RECV: $rl";
            if(($self->{'method'} ne 'GET') && ($self->{'method'} ne 'HEAD') && ($self->{'method'} ne 'PUT')) {
                say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . 'Invalid method: ' . $self->{'method'}. ', closing conn';
                return undef;
            }
            my ($path, $querystring) = ($self->{'uri'} =~ /^([^\?]+)(?:\?)?(.*)$/g);
            say("raw path: $path\nraw querystring: $querystring");

            # transformations
            ## Path
            $path = uri_unescape($path);
            my %pathStruct = ( 'unescapepath' => $path );

            # collapse slashes
            $path =~ s/\/{2,}/\//g;
            say "collapsed: $path";
            $pathStruct{'unsafecollapse'} = $path;

            # without trailing slash
            if(index($pathStruct{'unsafecollapse'}, '/', length($pathStruct{'unsafecollapse'})-1) != -1) {
                chop($path);
                say "no slash path: $path ";
            }
            $pathStruct{'unsafepath'} = $path;

            ## Querystring
            my %qsStruct;
            # In the querystring spaces are sometimes encoded as + for legacy reasons unfortunately
            $querystring =~ s/\+/%20/g;
            my @qsPairs = split('&', $querystring);
            foreach my $pair (@qsPairs) {
                my($key, $value) = split('=', $pair);
                if(defined $value) {
                    if(!defined $qsStruct{$key}) {
                        $qsStruct{$key} = uri_unescape($value);
                    }
                    else {
                        if(ref($qsStruct{$key}) ne 'ARRAY') {
                            $qsStruct{$key} = [$qsStruct{$key}];
                        };
                        push @{$qsStruct{$key}}, uri_unescape($value);
                    }
                }

lib/MHFS/HTTP/Server/Client/Request.pm  view on Meta::CPAN

            return 1;
        }
        elsif(substr($self->{'client'}{'inbuf'}, 0, $ipos+2, '') =~ /^(([^:]+):\s*(.*))\r\n/) {
            say "RECV: $1";
            $self->{'header'}{$2} = $3;
        }
        else {
            say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid header, closing conn';
            return undef;
        }
    }
    # when $ipos is 0 we recieved the end of the headers: \r\n\r\n

    # verify correct host is specified when required
    if($self->{'client'}{'serverhostname'}) {
        if((! $self->{'header'}{'Host'}) ||
        ($self->{'header'}{'Host'} ne $self->{'client'}{'serverhostname'})) {
            my $printhostname = $self->{'header'}{'Host'} // '';
            say "Host: $printhostname does not match ". $self->{'client'}{'serverhostname'};
            return undef;
        }
    }

    $self->{'ip'} = $self->{'client'}{'ip'};

    # check if we're trusted (we can trust the headers such as from reverse proxy)
    my $trusted;
    if($self->{'client'}{'X-MHFS-PROXY-KEY'} && $self->{'header'}{'X-MHFS-PROXY-KEY'}) {
        $trusted = $self->{'client'}{'X-MHFS-PROXY-KEY'} eq $self->{'header'}{'X-MHFS-PROXY-KEY'};
    }
    # drops conns for naughty client's using forbidden headers
    if(!$trusted) {
        my @absolutelyforbidden = ('X-MHFS-PROXY-KEY', 'X-Forwarded-For');
        foreach my $forbidden (@absolutelyforbidden) {
            if( exists $self->{'header'}{$forbidden}) {
                say "header $forbidden is forbidden!";
                return undef;
            }
        }
    }
    # process reverse proxy headers
    else {
        delete $self->{'header'}{'X-MHFS-PROXY-KEY'};
        try { $self->{'ip'} = parse_ipv4($self->{'header'}{'X-Forwarded-For'}) if($self->{'header'}{'X-Forwarded-For'}); }
        catch ($e) { say "ip not updated, unable to parse X-Forwarded-For: " . $self->{'header'}{'X-Forwarded-For'}; }
    }
    my $netmap = $self->{'client'}{'server'}{'settings'}{'NETMAP'};
    if($netmap && (($self->{'ip'} >> 24) == $netmap->[0])) {
        say "HACK for netmap converting to local ip";
        $self->{'ip'} = ($self->{'ip'} & 0xFFFFFF) | ($netmap->[1] << 24);
    }

    # remove the final \r\n
    substr($self->{'client'}{'inbuf'}, 0, 2, '');
    if((defined $self->{'header'}{'Range'}) &&  ($self->{'header'}{'Range'} =~ /^bytes=([0-9]+)\-([0-9]*)$/)) {
        $self->{'header'}{'_RangeStart'} = $1;
        $self->{'header'}{'_RangeEnd'} = ($2 ne  '') ? $2 : undef;
    }
    $self->{'on_read_ready'} = undef;
    $self->{'client'}->SetEvents(MHFS::EventLoop::Poll->ALWAYSMASK );
    $self->{'client'}->KillClientCloseTimer($self->{'recvrequesttimerid'});
    $self->{'recvrequesttimerid'} = undef;

    # finally handle the request
    foreach my $route (@{$self->{'client'}{'server'}{'routes'}}) {
        if($self->{'path'}{'unsafecollapse'} eq $route->[0]) {
            $route->[1]($self);
            return 1;
        }
        else {
            # wildcard ending
            next if(index($route->[0], '*', length($route->[0])-1) == -1);
            next if(rindex($self->{'path'}{'unsafecollapse'}, substr($route->[0], 0, -1), 0) != 0);
            $route->[1]($self);
            return 1;
        }
    }
    $self->{'client'}{'server'}{'route_default'}($self);
    return 1;
}

# unfortunately the absolute url of the server is required for stuff like m3u playlist generation
sub getAbsoluteURL {
    my ($self) = @_;
    return $self->{'client'}{'absurl'} // (defined($self->{'header'}{'Host'}) ? 'http://'.$self->{'header'}{'Host'} : undef);
}

sub _ReqDataLength {
    my ($self, $datalength) = @_;
    $datalength //= 99999999999;
    my $end =  $self->{'header'}{'_RangeEnd'} // ($datalength-1);
    my $dl = $end+1;
    say "_ReqDataLength returning: $dl";
    return $dl;
}

sub _SendResponse {
    my ($self, $fileitem) = @_;
    if(Encode::is_utf8($fileitem->{'buf'})) {
        warn "_SendResponse: UTF8 flag is set, turning off";
        Encode::_utf8_off($fileitem->{'buf'});
    }
    if($self->{'outheaders'}{'Transfer-Encoding'} && ($self->{'outheaders'}{'Transfer-Encoding'} eq 'chunked')) {
        say "chunked response";
        $fileitem->{'is_chunked'} = 1;
    }

    $self->{'response'} = $fileitem;
    $self->{'client'}->SetEvents(POLLOUT | MHFS::EventLoop::Poll->ALWAYSMASK );
}

sub _SendDataItem {
    my ($self, $dataitem, $opt) = @_;
    my $size  = $opt->{'size'};
    my $code = $opt->{'code'};

    if(! $code) {
        # if start is defined it's a range request
        if(defined $self->{'header'}{'_RangeStart'}) {
            $code = 206;
        }
        else {