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 {

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

        if($end < $start) {
            say "_SendDataItem, end < start";
            $self->Send403();
            return;
        }
        $self->{'outheaders'}{'Content-Range'} = "bytes $start-$end/" . ($size // '*');
    }
    # everybody else
    else {
        $contentlength = $size;
    }

    # if the CL isn't known we need to send chunked
    if(! defined $contentlength) {
        $self->{'outheaders'}{'Transfer-Encoding'} = 'chunked';
    }
    else {
        $self->{'outheaders'}{'Content-Length'} = "$contentlength";
    }



    my %lookup = (
        200 => "HTTP/1.1 200 OK\r\n",
        206 => "HTTP/1.1 206 Partial Content\r\n",
        301 => "HTTP/1.1 301 Moved Permanently\r\n",
        307 => "HTTP/1.1 307 Temporary Redirect\r\n",
        403 => "HTTP/1.1 403 Forbidden\r\n",
        404 => "HTTP/1.1 404 File Not Found\r\n",
        408 => "HTTP/1.1 408 Request Timeout\r\n",
        416 => "HTTP/1.1 416 Range Not Satisfiable\r\n",
        503 => "HTTP/1.1 503 Service Unavailable\r\n"
    );

    my $headtext = $lookup{$code};
    if(!$headtext) {
        say "_SendDataItem, bad code $code";
        $self->Send403();
        return;
    }
    my $mime     = $opt->{'mime'};
    $headtext .=   "Content-Type: $mime\r\n";

    my $filename = $opt->{'filename'};
    my $disposition = 'inline';
    if($opt->{'attachment'}) {
        $disposition = 'attachment';
        $filename = $opt->{'attachment'};
    }
    elsif($opt->{'inline'}) {
        $filename = $opt->{'inline'};
    }
    if($filename) {
        my $sendablebytes = encode('UTF-8', get_printable_utf8($filename));
        $headtext .=   "Content-Disposition: $disposition; filename*=UTF-8''".uri_escape($sendablebytes)."; filename=\"$sendablebytes\"\r\n";
    }

    $self->{'outheaders'}{'Accept-Ranges'} //= 'bytes';
    $self->{'outheaders'}{'Connection'} //= $self->{'header'}{'Connection'};
    $self->{'outheaders'}{'Connection'} //= 'keep-alive';

    # SharedArrayBuffer
    if($opt->{'allowSAB'}) {
        say "sending SAB headers";
        $self->{'outheaders'}{'Cross-Origin-Opener-Policy'} =  'same-origin';
        $self->{'outheaders'}{'Cross-Origin-Embedder-Policy'} = 'require-corp';
    }

    # serialize the outgoing headers
    foreach my $header (keys %{$self->{'outheaders'}}) {
        $headtext .= "$header: " . $self->{'outheaders'}{$header} . "\r\n";
    }

    $headtext .= "\r\n";
    $dataitem->{'buf'} = $headtext;

    if($dataitem->{'fh'}) {
        $dataitem->{'fh_pos'} = tell($dataitem->{'fh'});
        $dataitem->{'get_current_length'} //= sub { return undef };
    }

    $self->_SendResponse($dataitem);
}

sub Send400 {
    my ($self) = @_;
    my $msg = "400 Bad Request\r\n";
    $self->SendHTML($msg, {'code' => 403});
}

sub Send403 {
    my ($self) = @_;
    my $msg = "403 Forbidden\r\n";
    $self->SendHTML($msg, {'code' => 403});
}

sub Send404 {
    my ($self) = @_;
    my $msg = "404 Not Found";
    $self->SendHTML($msg, {'code' => 404});
}

sub Send408 {
    my ($self) = @_;
    my $msg = "408 Request Timeout";
    $self->{'outheaders'}{'Connection'} = 'close';
    $self->SendHTML($msg, {'code' => 408});
}

sub Send416 {
    my ($self, $cursize) = @_;
    $self->{'outheaders'}{'Content-Range'} = "*/$cursize";
    $self->SendHTML('', {'code' => 416});
}

sub Send503 {
    my ($self) = @_;
    $self->{'outheaders'}{'Retry-After'} = 5;
    my $msg = "503 Service Unavailable";
    $self->SendHTML($msg, {'code' => 503});