|
@@ -33,6 +33,7 @@ use Trog::Utils;
|
|
|
use Trog::Config;
|
|
use Trog::Config;
|
|
|
use Trog::Data;
|
|
use Trog::Data;
|
|
|
use Trog::Vars;
|
|
use Trog::Vars;
|
|
|
|
|
+use Trog::FileHandler;
|
|
|
|
|
|
|
|
# Troglodyne philosophy - simple as possible
|
|
# Troglodyne philosophy - simple as possible
|
|
|
|
|
|
|
@@ -52,15 +53,6 @@ my %aliases = $data->aliases();
|
|
|
# This should eventually be pre-filled from DB.
|
|
# This should eventually be pre-filled from DB.
|
|
|
my %etags;
|
|
my %etags;
|
|
|
|
|
|
|
|
-#1MB chunks
|
|
|
|
|
-my $CHUNK_SIZE = 1024000;
|
|
|
|
|
-my $CHUNK_SEP = 'tCMSep666YOLO42069';
|
|
|
|
|
-
|
|
|
|
|
-#Stuff that isn't in upstream finders
|
|
|
|
|
-my %extra_types = (
|
|
|
|
|
- '.docx' => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
|
|
|
|
|
-);
|
|
|
|
|
-
|
|
|
|
|
=head2 app()
|
|
=head2 app()
|
|
|
|
|
|
|
|
Dispatches requests based on %routes built above.
|
|
Dispatches requests based on %routes built above.
|
|
@@ -104,7 +96,7 @@ sub app {
|
|
|
if ( $env->{REQUEST_METHOD} eq 'POST' ) {
|
|
if ( $env->{REQUEST_METHOD} eq 'POST' ) {
|
|
|
|
|
|
|
|
my $body = HTTP::Body->new( $env->{CONTENT_TYPE}, $env->{CONTENT_LENGTH} );
|
|
my $body = HTTP::Body->new( $env->{CONTENT_TYPE}, $env->{CONTENT_LENGTH} );
|
|
|
- while ( $env->{'psgi.input'}->read( my $buf, $CHUNK_SIZE ) ) {
|
|
|
|
|
|
|
+ while ( $env->{'psgi.input'}->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
|
|
|
$body->add($buf);
|
|
$body->add($buf);
|
|
|
}
|
|
}
|
|
|
|
|
|
|
@@ -117,6 +109,8 @@ sub app {
|
|
|
|
|
|
|
|
my $path = $env->{PATH_INFO};
|
|
my $path = $env->{PATH_INFO};
|
|
|
$path = '/index' if $path eq '/';
|
|
$path = '/index' if $path eq '/';
|
|
|
|
|
+ #XXX this is hardcoded in browsers, so just rewrite the path
|
|
|
|
|
+ $path = '/img/icon/favicon.ico' if $path eq '/favicon.ico';
|
|
|
|
|
|
|
|
# Translate alias paths into their actual path
|
|
# Translate alias paths into their actual path
|
|
|
$path = $aliases{$path} if exists $aliases{$path};
|
|
$path = $aliases{$path} if exists $aliases{$path};
|
|
@@ -186,14 +180,14 @@ sub app {
|
|
|
map {
|
|
map {
|
|
|
[ split( /-/, $_ ) ];
|
|
[ split( /-/, $_ ) ];
|
|
|
|
|
|
|
|
- #$tuples[1] //= $tuples[0] + $CHUNK_SIZE;
|
|
|
|
|
|
|
+ #$tuples[1] //= $tuples[0] + $Trog::Vars::CHUNK_SIZE;
|
|
|
#\@tuples
|
|
#\@tuples
|
|
|
} split( /,/, $range )
|
|
} split( /,/, $range )
|
|
|
);
|
|
);
|
|
|
}
|
|
}
|
|
|
|
|
|
|
|
- return _serve( "www/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "www/$path";
|
|
|
|
|
- return _serve( "totp/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "totp/$path" && $active_user;
|
|
|
|
|
|
|
+ return Trog::FileHandler::serve( "www/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "www/$path";
|
|
|
|
|
+ return Trog::FileHandler::serve( "totp/$path", $start, $streaming, \@ranges, $last_fetch, $deflate ) if -f "totp/$path" && $active_user;
|
|
|
|
|
|
|
|
#Handle regex/capture routes
|
|
#Handle regex/capture routes
|
|
|
if ( !exists $routes{$path} ) {
|
|
if ( !exists $routes{$path} ) {
|
|
@@ -305,7 +299,7 @@ sub _static ( $path, $start, $streaming, $last_fetch = 0 ) {
|
|
|
|
|
|
|
|
#push(@headers, 'Content-Length' => $sz);
|
|
#push(@headers, 'Content-Length' => $sz);
|
|
|
my $writer = $responder->( [ $code, [%$headers_parsed] ] );
|
|
my $writer = $responder->( [ $code, [%$headers_parsed] ] );
|
|
|
- while ( $fh->read( my $buf, $CHUNK_SIZE ) ) {
|
|
|
|
|
|
|
+ while ( $fh->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
|
|
|
$writer->write($buf);
|
|
$writer->write($buf);
|
|
|
}
|
|
}
|
|
|
close $fh;
|
|
close $fh;
|
|
@@ -318,131 +312,4 @@ sub _static ( $path, $start, $streaming, $last_fetch = 0 ) {
|
|
|
return [ 403, [ 'Content-Type' => $Trog::Vars::content_types{plain} ], ["STAY OUT YOU RED MENACE"] ];
|
|
return [ 403, [ 'Content-Type' => $Trog::Vars::content_types{plain} ], ["STAY OUT YOU RED MENACE"] ];
|
|
|
}
|
|
}
|
|
|
|
|
|
|
|
-sub _range ( $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;
|
|
|
|
|
- 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 _serve ( $path, $start, $streaming, $ranges, $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 ||= $Trog::Vars::content_types{plain};
|
|
|
|
|
-
|
|
|
|
|
- my $ct = 'Content-type';
|
|
|
|
|
- my @headers = ( $ct => $ft );
|
|
|
|
|
-
|
|
|
|
|
- #TODO use static Cache-Control for everything but JS/CSS?
|
|
|
|
|
- push( @headers, 'Cache-control' => $Trog::Vars::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( $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) );
|
|
|
|
|
-
|
|
|
|
|
- # Append server-timing headers
|
|
|
|
|
- my $tot = tv_interval($start) * 1000;
|
|
|
|
|
- push( @headers, 'Server-Timing' => "file;dur=$tot" );
|
|
|
|
|
-
|
|
|
|
|
- return [ $code, \@headers, [$dfh] ];
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- return [ 403, [ $ct => $Trog::Vars::content_types{plain} ], ["STAY OUT YOU RED MENACE"] ];
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
1;
|
|
1;
|