view release on metacpan or  search on metacpan

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

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);
                    }
                }
            }

            $self->{'path'} = \%pathStruct;
            $self->{'qs'} = \%qsStruct;
            $self->{'on_read_ready'} = \&want_headers;
            #return want_headers($self);
            goto &want_headers;
        }
        else {
            say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' Invalid Request line, closing conn';
            return undef;
        }
    }
    elsif(length($self->{'client'}{'inbuf'}) > MAX_REQUEST_SIZE) {
        say "X-MHFS-CONN-ID: " . $self->{'outheaders'}{'X-MHFS-CONN-ID'} . ' No Request line, closing conn';
        return undef;
    }
    return 1;
}

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

            }
            $request->Send404;
        }
        else {
            # redirect to slash path
            my $bn = basename($requestfile);
            $request->SendRedirect(301, $bn.'/');
        }
    }
    else {
        $request->Send404;
    }
}

sub SendDirectoryListing {
    my ($self, $absdir, $urldir) = @_;
    my $urf = $absdir .'/'.substr($self->{'path'}{'unsafepath'}, length($urldir));
    my $requestfile = abs_path($urf);
    my $ml = $absdir;
    say "rf $requestfile " if(defined $requestfile);
    if (( ! defined $requestfile) || (rindex($requestfile, $ml, 0) != 0)){
        $self->Send404;
        return;
    }

    if(-f $requestfile) {
        if(index($self->{'path'}{'unsafecollapse'}, '/', length($self->{'path'}{'unsafecollapse'})-1) == -1) {
            $self->SendFile($requestfile);
        }
        else {
            $self->Send404;
        }
        return;
    }
    elsif(-d _) {
        # ends with slash
        if((substr $self->{'path'}{'unescapepath'}, -1) eq '/') {
            opendir ( my $dh, $requestfile ) or die "Error in opening dir $requestfile\n";
            my $buf;
            my $filename;
            while( ($filename = readdir($dh))) {
                next if(($filename eq '.') || ($filename eq '..'));
                next if(!(-s "$requestfile/$filename"));
                my $url = uri_escape($filename);
                $url .= '/' if(-d _);
                $buf .= '<a href="' . $url .'">'.${escape_html_noquote(decode('UTF-8', $filename, Encode::LEAVE_SRC))} .'</a><br><br>';
            }
            closedir($dh);
            $self->SendHTML($buf);
            return;
        }
        # redirect to slash path
        else {
            $self->SendRedirect(301, basename($requestfile).'/');
            return;
        }
    }
    $self->Send404;
}

sub PUTBuf_old {
    my ($self, $handler) = @_;
    if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
        $self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
    }
    my $sdata;
    $self->{'on_read_ready'} = sub {
        my $contentlength = $self->{'header'}{'Content-Length'};
        $sdata .= $self->{'client'}{'inbuf'};
        my $dlength = length($sdata);
        if($dlength >= $contentlength) {
            say 'PUTBuf datalength ' . $dlength;
            my $data;
            if($dlength > $contentlength) {
                $data = substr($sdata, 0, $contentlength);
                $self->{'client'}{'inbuf'} = substr($sdata, $contentlength);
                $dlength = length($data)
            }
            else {
                $data = $sdata;
                $self->{'client'}{'inbuf'} = '';
            }
            $self->{'on_read_ready'} = undef;
            $handler->($data);
        }
        else {
            $self->{'client'}{'inbuf'} = '';
        }
        #return '';
        return 1;
    };
    $self->{'on_read_ready'}->();
}

sub PUTBuf {
    my ($self, $handler) = @_;
    if($self->{'header'}{'Content-Length'} > 20000000) {
        say "PUTBuf too big";
        $self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
        $self->{'on_read_ready'} = sub { return undef };
        return;
    }
    if(length($self->{'client'}{'inbuf'}) < $self->{'header'}{'Content-Length'}) {
        $self->{'client'}->SetEvents(POLLIN | MHFS::EventLoop::Poll->ALWAYSMASK );
    }
    $self->{'on_read_ready'} = sub {
        my $contentlength = $self->{'header'}{'Content-Length'};
        my $dlength = length($self->{'client'}{'inbuf'});
        if($dlength >= $contentlength) {
            say 'PUTBuf datalength ' . $dlength;
            my $data;
            if($dlength > $contentlength) {
                $data = substr($self->{'client'}{'inbuf'}, 0, $contentlength, '');
            }
            else {
                $data = $self->{'client'}{'inbuf'};
                $self->{'client'}{'inbuf'} = '';
            }
            $self->{'on_read_ready'} = undef;
            $handler->($data);
        }
        return 1;
    };
    $self->{'on_read_ready'}->();
}

sub SendFile {
    my ($self, $requestfile) = @_;
    foreach my $uploader (@{$self->{'client'}{'server'}{'uploaders'}}) {
        return if($uploader->($self, $requestfile));
    }
    say "SendFile - SendLocalFile $requestfile";
    return $self->SendLocalFile($requestfile);
}

1;