use strict; use warnings; no warnings 'experimental'; use feature qw{signatures}; use Date::Format qw{strftime}; use URL::Encode (); use Text::Xslate (); use Plack::MIME (); use Mojo::File (); use DateTime::Format::HTTP(); use Encode qw{encode_utf8}; #Grab our custom routes use lib 'lib'; use Trog::Routes::HTML; use Trog::Routes::JSON; # 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 $cd = 'Content-disposition'; my %content_dispositions = ( attachment => 'attachment; filename=', inline => 'inline; filename=', ); 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", ); 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}; #Disallow any paths that are naughty ( starman auto-removes .. up-traversal) if (index($path,'/templates') == 0 || $path =~ m/.*\.psgi$/i ) { return [ 403, [$content_types{plain}], ["STAY OUT YOU RED MENACE"]]; } # If it's just a file, serve it up return _serve("www/$path", $last_fetch) if -f "www/$path"; #TODO reject inappropriate content-lengths return [ 404, [$content_types{plain}], ["RETURN TO SENDER"]] unless exists $routes{$path}; return [ 400, [$content_types{plain}], ["BAD REQUEST"]] unless $routes{$path}{method} eq $env->{REQUEST_METHOD}; #TODO fish out what user is in cookie $query->{user} = 'Nobody'; my $output = $routes{$path}{callback}->($query,$env->{input}, \&_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 figure out content-disposition #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; 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) { 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} //= []; $vars->{contenttype} //= $content_types{html}; $vars->{cachecontrol} //= $cache_control{revalidate}; my @headers = ($vars->{contenttype}); push(@headers,$vars->{contentdisposition}) if $vars->{contentdisposition}; push(@headers, $vars->{cachecontrol}) if $vars->{cachecontrol}; my $h = join("\n",@headers); my $body = $processor->render($template,$vars); return [200, [$h], [encode_utf8($body)]]; }