Initial commit of static file server

download_deps_and_run.sh

@@ -0,0 +1,15 @@
+#!/bin/sh
+CURDIR=$(pwd)
+cd $HOME
+mkdir local-lib; /bin/true
+mkdir perl5; /bin/true
+cd local-lib
+curl https://cpan.metacpan.org/authors/id/H/HA/HAARG/local-lib-2.000029.tar.gz > locallib.tar.gz
+tar --one-top-level=src --strip-components=1 -zxf locallib.tar.gz
+cd src
+perl Makefile.PL --bootstrap
+cd ../..
+eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
+perl -Ilocal-lib/src/lib -MCPAN -Mlocal::lib -e 'CPAN::install(qw{Starman Plack::MIME IO::Compress::Gzip Time::HiRes Date::Format Sys::Hostname Plack::MIME Mojo::File DateTime::Format::HTTP Time::HiRes Log::Dispatch Log::Dispatch::Screen Log::Dispatch::FileRotate HTTP::Parser::XS})';
+cd $CURDIR
+perl -I~/perl5/lib/perl5 ~/perl5/bin/starman –port 7575 perl-static-file-server.pl

perl-static-file-server.pl

@@ -0,0 +1,437 @@
+#!/usr/bin/env starman
+
+use strict;
+use warnings;
+
+use POSIX();
+use Mojo::File;
+use Plack::MIME;
+use IO::Compress::Gzip;
+use Time::HiRes qw{tv_interval};
+
+# For CGI features
+use HTTP::Parser::XS qw{HEADERS_AS_HASHREF};
+use CGI::Emulate::PSGI;
+
+use Date::Format qw{strftime};
+use List::Util();
+use File::Find;
+use Sys::Hostname();
+use Plack::MIME  ();
+use DateTime::Format::HTTP();
+use Time::HiRes      qw{gettimeofday tv_interval};
+
+use Log::Dispatch;
+use Log::Dispatch::Screen;
+use Log::Dispatch::FileRotate;
+
+#1MB chunks
+our $CHUNK_SEP  = 'perlfsSep666YOLO42069';
+our $CHUNK_SIZE = 1024000;
+
+our %content_types = (
+    text  => "text/plain",
+    html  => "text/html",
+    json  => "application/json",
+    blob  => "application/octet-stream",
+    xml   => "text/xml",
+    xsl   => "text/xsl",
+    css   => "text/css",
+    rss   => "application/rss+xml",
+    email => "multipart/related",
+);
+
+our %byct = reverse %content_types;
+
+our %cache_control = (
+    revalidate => "no-cache, max-age=0",
+    nocache    => "no-store",
+    static     => "public, max-age=604800, immutable",
+);
+
+#TODO consider integrating libfile
+#Stuff that isn't in upstream finders
+my %extra_types = (
+    '.docx' => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
+);
+
+my $ct      = 'Content-type';
+my $LOGNAME = -d '/var/log' ? '/var/log/www/perlfs.log' : '~/.perlfs/perlfs.log';
+$LOGNAME = $ENV{CUSTOM_LOG} if $ENV{CUSTOM_LOG};
+
+my $LEVEL = $ENV{WWW_VERBOSE} ? 'debug' : 'info';
+
+# By default only log requests & warnings.
+# Otherwise emit debug messages.
+my $rotate = Log::Dispatch::FileRotate->new(
+    name      => 'tcms',
+    filename  => $LOGNAME,
+    min_level => $LEVEL,
+    'mode'    => 'append',
+    size      => 10 * 1024 * 1024,
+    max       => 6,
+);
+
+# Only send fatal events/errors to stdout
+my $screen = Log::Dispatch::Screen->new(
+    name      => 'screen',
+    min_level => $ENV{DEBUG} ? 'debug' : 'error',
+);
+our $log = Log::Dispatch->new();
+$log->add($rotate);
+$log->add($screen);
+
+#memoize
+my $rq;
+our $ip;
+my $cur_query = {};
+
+#XXX make perl -c quit whining
+BEGIN {
+    $ip   = '0.0.0.0';
+}
+
+sub _log {
+    my ( $msg ) = @_;
+
+    $msg //= "No message passed.  This is almost certainly a bug. ";
+
+    #XXX Log lines must start as an ISO8601 date, anything else breaks fail2ban's beautiful mind
+    my $tstamp = POSIX::strftime "%Y-%m-%dT%H:%M:%SZ", gmtime;
+
+    return "$tstamp : $ip $msg\n";
+}
+
+sub INFO {
+    $log->info( _log( shift ) );
+}
+
+# File serving
+# Let's walk the directory and build our routes ahead of time.
+my %routes;
+File::Find::find({ wanted => sub {
+    $routes{$_} = \&serve;
+}, follow => 1, no_chdir => 1},
+'www');
+
+=head2 serve
+
+Serve a file, with options to stream and cache the output.
+
+=cut
+
+sub serve {
+    my ( $fullpath, $path, $start, $streaming, $ranges, $last_fetch, $deflate ) = @_;
+    $last_fetch ||= 0;
+    $deflate    ||= 0;
+
+    my $mf  = Mojo::File->new($path);
+    my $ext = '.' . $mf->extname();
+    my $ft;
+    if ($ext) {
+        $ft = Plack::MIME->mime_type($ext) if $ext;
+        $ft ||= $extra_types{$ext}         if exists $extra_types{$ext};
+    }
+    $ft ||= $content_types{text};
+
+    my @headers = ( $ct => $ft );
+
+    #TODO use static Cache-Control for everything but JS/CSS?
+    push( @headers, 'Cache-control' => $cache_control{revalidate} );
+
+    push( @headers, 'Accept-Ranges' => 'bytes' );
+
+    my $mt         = ( stat($path) )[9];
+    my $sz         = ( stat(_) )[7];
+    my @gm         = gmtime($mt);
+    my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm );
+    my $code       = $mt > $last_fetch ? 200 : 304;
+
+    push( @headers, "Last-Modified" => $now_string );
+    push( @headers, 'Vary'          => 'Accept-Encoding' );
+
+    if ( open( my $fh, '<', $path ) ) {
+        return _range( $fullpath, $fh, $ranges, $sz, @headers ) if @$ranges && $streaming;
+
+        # Transfer-encoding: chunked
+        return sub {
+            my $responder = shift;
+            push( @headers, 'Content-Length' => $sz );
+            my $writer = $responder->( [ $code, \@headers ] );
+            while ( $fh->read( my $buf, $CHUNK_SIZE ) ) {
+                $writer->write($buf);
+            }
+            close $fh;
+            $writer->close;
+          }
+          if $streaming && $sz > $CHUNK_SIZE;
+
+        #Return data in the event the caller does not support deflate
+        if ( !$deflate ) {
+            push( @headers, "Content-Length" => $sz );
+
+            # Append server-timing headers
+            my $tot = tv_interval($start) * 1000;
+            push( @headers, 'Server-Timing' => "file;dur=$tot" );
+
+            return [ $code, \@headers, $fh ];
+        }
+
+        #Compress everything less than 1MB
+        push( @headers, "Content-Encoding" => "gzip" );
+        my $dfh;
+        IO::Compress::Gzip::gzip( $fh => \$dfh );
+        print $IO::Compress::Gzip::GzipError if $IO::Compress::Gzip::GzipError;
+        push( @headers, "Content-Length" => length($dfh) );
+
+        INFO("GET 200 $fullpath");
+
+        # Append server-timing headers
+        my $tot = tv_interval($start) * 1000;
+        push( @headers, 'Server-Timing' => "file;dur=$tot" );
+
+        return [ $code, \@headers, [$dfh] ];
+    }
+
+    INFO("GET 403 $fullpath");
+    return [ 403, [ $ct => $content_types{text} ], ["Forbidden"] ];
+}
+
+sub _range {
+    my ( $fullpath, $fh, $ranges, $sz, %headers ) = @_;
+    # Set mode
+    my $primary_ct   = "Content-Type: $headers{'Content-type'}";
+    my $is_multipart = scalar(@$ranges) > 1;
+    if ($is_multipart) {
+        $headers{'Content-type'} = "multipart/byteranges; boundary=$CHUNK_SEP";
+    }
+    my $code = 206;
+
+    my $fc = '';
+
+    # Calculate the content-length up-front.  We have to fix unspecified lengths first, and reject bad requests.
+    foreach my $range (@$ranges) {
+        $range->[1] //= $sz - 1;
+        INFO("GET 416 $fullpath");
+        return [ 416, [%headers], ["Requested range not satisfiable"] ] if $range->[0] > $sz || $range->[0] < 0 || $range->[1] < 0 || $range->[0] > $range->[1];
+    }
+    $headers{'Content-Length'} = List::Util::sum( map { my $arr = $_; $arr->[1] + 1, -$arr->[0] } @$ranges );
+
+    #XXX Add the entity header lengths to the value - should hash-ify this to DRY
+    if ($is_multipart) {
+        foreach my $range (@$ranges) {
+            $headers{'Content-Length'} += length("$fc--$CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n");
+            $fc = "\n";
+        }
+        $headers{'Content-Length'} += length("\n--$CHUNK_SEP\--\n");
+        $fc = '';
+    }
+
+    return sub {
+        my $responder = shift;
+        my $writer;
+
+        foreach my $range (@$ranges) {
+            $headers{'Content-Range'} = "bytes $range->[0]-$range->[1]/$sz" unless $is_multipart;
+            $writer //= $responder->( [ $code, [%headers] ] );
+            $writer->write("$fc--$CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n") if $is_multipart;
+            $fc = "\n";
+
+            my $len = List::Util::min( $sz, $range->[1] + 1 ) - $range->[0];
+
+            $fh->seek( $range->[0], 0 );
+            while ($len) {
+                $fh->read( my $buf, List::Util::min( $len, $CHUNK_SIZE ) );
+                $writer->write($buf);
+
+                # Adjust for amount written
+                $len = List::Util::max( $len - $CHUNK_SIZE, 0 );
+            }
+        }
+        $fh->close();
+        $writer->write("\n--$CHUNK_SEP\--\n") if $is_multipart;
+        $writer->close;
+    };
+}
+
+sub _generic {
+    my ( $type, $code ) = @_;
+    return [$code, [$ct => $content_types{text}], ["$type"]];
+}
+
+sub _notfound {
+    my $query = shift;
+    INFO("$query->{method} 404 $query->{fullpath}");
+    return _generic( 'not found', 404 );
+}
+
+sub _forbidden {
+    my $query = shift;
+    INFO("$query->{method} 403 $query->{fullpath}");
+    return _generic( 'forbidden', 403 );
+}
+
+sub _badrequest {
+    my $query = shift;
+    INFO("$query->{method} 400 $query->{fullpath}");
+    return _generic( 'bad request', 400 );
+}
+
+sub _toolong {
+    my $query = shift;
+    INFO("$query->{method} 419 $query->{fullpath}");
+    return _generic( 'URI too long', 419 );
+}
+
+sub _error {
+    my $query = shift;
+    INFO("$query->{method} 500 $query->{fullpath}");
+    return _generic( 'Internal Server Error', 500 );
+}
+
+my %etags;
+my $domain;
+sub _app {
+    # Start the server timing clock
+    my $start = [gettimeofday];
+
+    my $env = shift;
+
+    # Discard the path used in the log, it's too long and enough 4xx error code = ban
+    return _toolong({ method => $env->{REQUEST_METHOD}, fullpath => '...' }) if length( $env->{REQUEST_URI} ) > 2048;
+
+    # Various stuff important for logging requests
+    $domain //= eval { Sys::Hostname::hostname() } // $env->{HTTP_X_FORWARDED_HOST} || $env->{HTTP_HOST};
+    my $path = $env->{PATH_INFO};
+    my $port   = $env->{HTTP_X_FORWARDED_PORT} // $env->{HTTP_PORT};
+    my $pport  = defined $port ? ":$port" : "";
+    my $scheme = $env->{'psgi.url_scheme'} // 'http';
+    my $method = $env->{REQUEST_METHOD};
+
+    # It's important that we log what the user ACTUALLY requested rather than the rewritten path later on.
+    my $fullpath = "$scheme://$domain$pport$path";
+
+    # sigdie can now "do the right thing"
+    $cur_query = { route => $path, fullpath => $path, method => $method };
+
+    # Check eTags.  If we don't know about it, just assume it's good and lazily fill the cache
+    # XXX yes, this allows cache poisoning...but only for logged in users!
+    if ( $env->{HTTP_IF_NONE_MATCH} ) {
+        INFO("$env->{REQUEST_METHOD} 304 $fullpath");
+        return [ 304, [], [''] ] if $env->{HTTP_IF_NONE_MATCH} eq ( $etags{ $env->{REQUEST_URI} } || '' );
+        $etags{ $env->{REQUEST_URI} } = $env->{HTTP_IF_NONE_MATCH} unless exists $etags{ $env->{REQUEST_URI} };
+    }
+
+    # TODO: Actually do something with the language passed to the renderer
+    my $lang = $env->{HTTP_ACCEPT_LANGUAGE};
+
+    #TODO: Actually do something with the acceptable output formats in the renderer
+    my $accept = $env->{HTTP_ACCEPT};
+
+    my $last_fetch = 0;
+    if ( $env->{HTTP_IF_MODIFIED_SINCE} ) {
+        $last_fetch = DateTime::Format::HTTP->parse_datetime( $env->{HTTP_IF_MODIFIED_SINCE} )->epoch();
+    }
+
+    # Figure out if we want compression or not
+    my $alist = $env->{HTTP_ACCEPT_ENCODING} || '';
+    $alist =~ s/\s//g;
+    my @accept_encodings;
+    @accept_encodings = split( /,/, $alist );
+    my $deflate = grep { 'gzip' eq $_ } @accept_encodings;
+
+    # Set the IP of the request so we can fail2ban
+    $ip = $env->{HTTP_X_FORWARDED_FOR} || $env->{REMOTE_ADDR};
+
+    my $streaming = $env->{'psgi.streaming'};
+
+    # Handle HTTP range/streaming requests
+    my $range = $env->{HTTP_RANGE} || "bytes=0-" if $env->{HTTP_RANGE} || $env->{HTTP_IF_RANGE};
+
+    my @ranges;
+    if ($range) {
+        $range =~ s/bytes=//g;
+        push(
+            @ranges,
+            map {
+                [ split( /-/, $_ ) ];
+            } split( /,/, $range )
+        );
+    }
+
+    # Do a case insensitive match, because osx and windows
+    my $file_actual = List::Util::first { lc($_) eq lc("www$path") } keys(%routes);
+
+    # Dirindices
+    if (!$file_actual) {
+        my $dirindex = lc("www$path/index.htm");
+        $dirindex =~ s|//|/|g;
+        $file_actual = List::Util::first { index(lc($_), $dirindex) == 0  } keys(%routes);
+    }
+
+    my $file_is_cgi = $file_actual ? -x $file_actual : 0;
+    return cgi( $env, $fullpath, $file_actual, $last_fetch, $deflate) if $file_is_cgi;
+    return serve( $fullpath, $file_actual, $start, $streaming, \@ranges, $last_fetch, $deflate ) if $file_actual;
+    return _notfound($cur_query);
+}
+
+# Read until we are done with headers, then pass off the filehandle to PSGI for streaming.
+# TODO support compression
+sub cgi {
+    my ( $env, $fullpath, $file_actual, $last_fetch, $deflate) = @_;
+    my $interpreter = $^X;
+
+    # Setup the CGI vars they expect
+    local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env));
+
+    my $pid = open(my $out, '-|', "$file_actual");
+    my ($code, %headers) = _extract_headers($out, $last_fetch);
+    return sub {
+        my $responder = shift;
+
+        my $writer = $responder->( [ $code, [%headers] ] );
+        while ( $out->read( my $buf, $CHUNK_SIZE ) ) {
+            $writer->write($buf);
+        }
+        $writer->close;
+        # Wait on the CGI script to do whatever it's doing after closing stdout
+        close $out;
+        waitpid($pid, 0);
+    };
+}
+
+
+sub _extract_headers {
+    my ($fh, $last_fetch) = @_;
+    my $headers = '';
+
+    # NOTE: this is relying on while advancing the file pointer
+    while (<$fh>) {
+        last if $_ eq "\n";
+        $headers .= $_;
+    }
+    my ( undef, undef, $status, undef, $headers_parsed ) = HTTP::Parser::XS::parse_http_response( "$headers\n", HEADERS_AS_HASHREF );
+
+    my $mt         = ( stat($fh) )[9];
+    my @gm         = gmtime($mt);
+    my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm );
+    my $code       = $mt > $last_fetch ? $status : 304;
+    $headers_parsed->{"Last-Modified"} = $now_string;
+
+    return ($code, %$headers_parsed);
+}
+
+our $app = sub {
+    return eval { _app(@_) } || do {
+		my $env = shift;
+        $env->{'psgi.errors'}->print($@);
+
+		# Redact the stack trace past line 1, it usually has things which should not be shown
+		$cur_query->{message} = $@;
+		$cur_query->{message} =~ s/\n.*//g if $cur_query->{message};
+
+		return _error($cur_query);
+    };
+};
+
+