123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297 |
- package TCMS;
- use strict;
- use warnings;
- no warnings 'experimental';
- use feature qw{signatures};
- use Date::Format qw{strftime};
- use HTTP::Body ();
- use URL::Encode ();
- use Text::Xslate ();
- use Plack::MIME ();
- use Mojo::File ();
- use DateTime::Format::HTTP();
- use Encode qw{encode_utf8};
- use CGI::Cookie ();
- use File::Basename();
- use IO::Compress::Deflate();
- #Grab our custom routes
- use lib 'lib';
- use Trog::Routes::HTML;
- use Trog::Routes::JSON;
- use Trog::Auth;
- use Trog::Utils;
- use Trog::Config;
- use Trog::Data;
- # Troglodyne philosophy - simple as possible
- # Import the routes
- my $conf = Trog::Config::get();
- my $data = Trog::Data->new($conf);
- my %roots = $data->routes();
- my %routes = %Trog::Routes::HTML::routes;
- @routes{keys(%Trog::Routes::JSON::routes)} = values(%Trog::Routes::JSON::routes);
- @routes{keys(%roots)} = values(%roots);
- my %aliases = $data->aliases();
- #1MB chunks
- my $CHUNK_SIZE = 1024000;
- # Things we will actually produce from routes rather than just serving up files
- my $ct = 'Content-type';
- my %content_types = (
- plain => "text/plain;",
- html => "text/html; charset=UTF-8",
- json => "application/json;",
- blob => "application/octet-stream;",
- );
- my $cc = 'Cache-control';
- my %cache_control = (
- revalidate => "no-cache, max-age=0",
- nocache => "no-store",
- static => "public, max-age=604800, immutable",
- );
- #Stuff that isn't in upstream finders
- my %extra_types = (
- '.docx' => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
- );
- =head2 app()
- Dispatches requests based on %routes built above.
- The dispatcher here does *not* do anything with the authn/authz data. It sets those in the 'user' and 'acls' parameters of the query object passed to routes.
- If a path passed is not a defined route (or regex route), but exists as a file under www/, it will be served up immediately.
- =cut
- sub app {
- my $env = shift;
- my $last_fetch = 0;
- if ($env->{HTTP_IF_MODIFIED_SINCE}) {
- $last_fetch = DateTime::Format::HTTP->parse_datetime($env->{HTTP_IF_MODIFIED_SINCE})->epoch();
- }
- my $query = {};
- $query = URL::Encode::url_params_mixed($env->{QUERY_STRING}) if $env->{QUERY_STRING};
- my $path = $env->{PATH_INFO};
- # Translate alias paths into their actual path
- $path = $aliases{$path} if exists $aliases{$path};
- # Collapse multiple slashes in the path
- $path =~ s/[\/]+/\//g;
- # Let's open up our default route before we bother to see if users even exist
- return $routes{default}{callback}->($query,\&_render) unless -f "config/setup";
- my $cookies = {};
- if ($env->{HTTP_COOKIE}) {
- $cookies = CGI::Cookie->parse($env->{HTTP_COOKIE});
- }
- my $active_user = '';
- if (exists $cookies->{tcmslogin}) {
- $active_user = Trog::Auth::session2user($cookies->{tcmslogin}->value);
- }
- #Disallow any paths that are naughty ( starman auto-removes .. up-traversal)
- if (index($path,'/templates') == 0 || $path =~ m/.*\.psgi$/i ) {
- return Trog::Routes::HTML::forbidden($query, \&_render);
- }
- # If it's just a file, serve it up
- my $alist = $env->{HTTP_ACCEPT_ENCODING} || '';
- $alist =~ s/\s//g;
- my @accept_encodings;
- @accept_encodings = split(/,/, $alist);
- my $deflate = grep { 'deflate' eq $_ } @accept_encodings;
- return _serve("www/$path", $env->{'psgi.streaming'}, $last_fetch, $deflate) if -f "www/$path";
- #Handle regex/capture routes
- if (!exists $routes{$path}) {
- my @captures;
- foreach my $pattern (keys(%routes)) {
- @captures = $path =~ m/^$pattern$/;
- if (@captures) {
- $path = $pattern;
- foreach my $field (@{$routes{$path}{captures}}) {
- $routes{$path}{data} //= {};
- $routes{$path}{data}{$field} = shift @captures;
- }
- last;
- }
- }
- }
- $query->{deflate} = $deflate;
- $query->{user} = $active_user;
- return Trog::Routes::HTML::notfound($query, \&_render) unless exists $routes{$path};
- return Trog::Routes::HTML::badrequest($query, \&_render) unless grep { $env->{REQUEST_METHOD} eq $_ } ($routes{$path}{method},'HEAD');
- @{$query}{keys(%{$routes{$path}{'data'}})} = values(%{$routes{$path}{'data'}}) if ref $routes{$path}{'data'} eq 'HASH' && %{$routes{$path}{'data'}};
- #Actually parse the POSTDATA and dump it into the QUERY object if this is a POST
- if ($env->{REQUEST_METHOD} eq 'POST') {
- my $body = HTTP::Body->new( $env->{CONTENT_TYPE}, $env->{CONTENT_LENGTH} );
- while ( read($env->{'psgi.input'}, my $buf, $CHUNK_SIZE) ) {
- $body->add($buf);
- }
- @$query{keys(%{$body->param})} = values(%{$body->param});
- @$query{keys(%{$body->upload})} = values(%{$body->upload});
- }
- #Set various things we don't want overridden
- $query->{acls} = Trog::Auth::acls4user($active_user) // [] if $active_user;
- $query->{user} = $active_user;
- $query->{domain} = $env->{HTTP_X_FORWARDED_HOST} || $env->{HTTP_HOST};
- $query->{route} = $path;
- #$query->{route} = $env->{REQUEST_URI};
- #$query->{route} =~ s/\?\Q$env->{QUERY_STRING}\E//;
- $query->{scheme} = $env->{'psgi.url_scheme'} // 'http';
- $query->{social_meta} = 1;
- $query->{primary_post} = {};
- #XXX there is a trick to now use strict refs, but I don't remember it right at the moment
- {
- no strict 'refs';
- my $output = $routes{$path}{callback}->($query, \&_render);
- return $output;
- }
- };
- sub _serve ($path, $streaming=0, $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{plain};
- my @headers = ($ct => $ft);
- #TODO use static Cache-Control for everything but JS/CSS?
- push(@headers,$cc => $cache_control{revalidate});
- #TODO Return 304 unchanged for files that haven't changed since the requestor reports they last fetched
- 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;
- #XXX something broken about the above logic
- $code=200;
- #XXX doing metadata=preload on videos doesn't work right?
- #push(@headers, "Content-Length: $sz");
- push(@headers, "Last-Modified" => $now_string);
- if (open(my $fh, '<', $path)) {
- return sub {
- my $responder = shift;
- my $writer = $responder->([ $code, \@headers]);
- while ( read($fh, 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 );
- return [ $code, \@headers, $fh];
- }
- #Compress everything less than 1MB
- push( @headers, "Content-Encoding" => "deflate" );
- my $dfh;
- IO::Compress::Deflate::deflate( $fh => \$dfh );
- print $IO::Compress::Deflate::DeflateError if $IO::Compress::Deflate::DeflateError;
- push( @headers, "Content-Length" => length($dfh) );
- return [ $code, \@headers, [$dfh]];
- }
- return [ 403, [$ct => $content_types{plain}], ["STAY OUT YOU RED MENACE"]];
- }
- sub _render ($template, $vars, @headers) {
- my $processor = Text::Xslate->new(
- path => 'www/templates',
- header => ['header.tx'],
- footer => ['footer.tx'],
- function => {
- iso8601 => sub {
- my $t = shift;
- my $dt = DateTime->from_epoch( epoch => $t );
- return $dt->iso8601;
- },
- strip_and_trunc => \&Trog::Utils::strip_and_trunc,
- },
- );
- #XXX default vars that need to be pulled from config
- $vars->{dir} //= 'ltr';
- $vars->{lang} //= 'en-US';
- $vars->{title} //= 'tCMS';
- #XXX Need to have minification detection and so forth, use LESS
- $vars->{stylesheets} //= [];
- #XXX Need to have minification detection, use Typescript
- $vars->{scripts} //= [];
- # Absolute-ize the paths for scripts & stylesheets
- @{$vars->{stylesheets}} = map { index($_, '/') == 0 ? $_ : "/$_" } @{$vars->{stylesheets}};
- @{$vars->{scripts}} = map { index($_, '/') == 0 ? $_ : "/$_" } @{$vars->{scripts}};
- $vars->{contenttype} //= $content_types{html};
- $vars->{cachecontrol} //= $cache_control{revalidate};
- $vars->{code} ||= 200;
- push(@headers, $ct => $vars->{contenttype});
- push(@headers, $cc => $vars->{cachecontrol}) if $vars->{cachecontrol};
- my $body = $processor->render($template,$vars);
- $body = encode_utf8($body);
- #Return data in the event the caller does not support deflate
- if (!$vars->{deflate}) {
- push( @headers, "Content-Length" => length($body) );
- return [ $vars->{code}, \@headers, [$body]];
- }
- #Compress
- push( @headers, "Content-Encoding" => "deflate" );
- #Disallow framing UNLESS we are in embed mode
- push( @headers, "Content-Security-Policy" => qq{frame-ancestors 'none'} ) unless $vars->{embed};
- my $dfh;
- IO::Compress::Deflate::deflate( \$body => \$dfh );
- print $IO::Compress::Deflate::DeflateError if $IO::Compress::Deflate::DeflateError;
- push( @headers, "Content-Length" => length($dfh) );
- return [$vars->{code}, \@headers, [$dfh]];
- }
- 1;
|