123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203 |
- 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();
- #Grab our custom routes
- use lib 'lib';
- use Trog::Routes::HTML;
- use Trog::Routes::JSON;
- use Trog::Auth;
- # Troglodyne philosophy - simple as possible
- # Import the routes
- my %routes = %Trog::Routes::HTML::routes;
- @routes{keys(%Trog::Routes::JSON::routes)} = values(%Trog::Routes::JSON::routes);
- # Things we will actually produce from routes rather than just serving up files
- my $ct = 'Content-type';
- my %content_types = (
- plain => "$ct:text/plain;",
- html => "$ct:text/html; charset=UTF-8",
- json => "$ct:application/json;",
- blob => "$ct:application/octet-stream;",
- );
- my $cc = 'Cache-control';
- my %cache_control = (
- revalidate => "$cc: no-cache, max-age=0;",
- nocache => "$cc: no-store;",
- static => "$cc: public, max-age=604800, immutable",
- );
- =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
- my $app = sub {
- 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};
- # Let's open up our default route before we bother to see if users even exist
- return $routes{default}{callback}->($query,\&_render) unless -f "$ENV{HOME}/.tcms/setup";
- my $cookies = {};
- if ($env->{HTTP_COOKIE}) {
- $cookies = CGI::Cookie->parse($env->{HTTP_COOKIE});
- }
- my ($active_user,$user_id) = ('','');
- if (exists $cookies->{tcmslogin}) {
- ($active_user,$user_id) = 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
- return _serve("www/$path", $last_fetch) 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->{user} = $active_user;
- return Trog::Routes::HTML::notfound($query, \&_render) unless exists $routes{$path};
- return Trog::Routes::HTML::badrequest($query, \&_render) unless $routes{$path}{method} eq $env->{REQUEST_METHOD};
- @{$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} );
- my $len = $env->{CONTENT_LENGTH};
- while ( $len ) {
- read($env->{'psgi.input'}, my $buf, ($len < 8192) ? 8192 : $len );
- $len -= length($buf);
- $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($user_id) // [] if $user_id;
- $query->{user} = $active_user;
- $query->{domain} = $env->{HTTP_HOST};
- $query->{route} = $env->{REQUEST_URI};
- $query->{scheme} = $env->{'psgi.url_scheme'} // 'http';
- my $output = $routes{$path}{callback}->($query, \&_render);
- return $output;
- };
- sub _serve ($path, $last_fetch=0) {
- my $mf = Mojo::File->new($path);
- my $ext = '.'.$mf->extname();
- my $ft;
- $ft = Plack::MIME->mime_type($ext) if $ext;
- $ft = "$ct:$ft;" if $ft;
- $ft ||= $content_types{plain};
- my @headers = ($ft);
- #TODO use static Cache-Control for everything but JS/CSS?
- push(@headers,$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 @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;
- push(@headers, "Last-Modified: $now_string\n");
- my $h = join("\n",@headers);
- if (open(my $fh, '<', $path)) {
- return [ $code, [$h], $fh];
- }
- return [ 403, [$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'],
- );
- #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, $vars->{contenttype});
- push(@headers, $vars->{cachecontrol}) if $vars->{cachecontrol};
- my $h = join("\n",@headers);
- my $body = $processor->render($template,$vars);
- return [$vars->{code}, [$h], [encode_utf8($body)]];
- }
|