From 3b69df7a785bbfc5b8c4a1719c046f9800aa3548 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Sun, 28 Sep 2014 09:10:18 +0300 Subject: [PATCH] Refactoring, part II (HTML::Seamstress) --- app.psgi | 19 ++- css/custom.css | 3 +- lib/Plack/App/Gruntmaster.pm | 75 ++++------- lib/Plack/App/Gruntmaster/HTML.pm | 204 ++++++++++++++++++++++++++++++ tmpl/ct.en | 36 +++--- tmpl/ct_entry.en | 16 ++- tmpl/footer.en | 5 - tmpl/log.en | 21 +-- tmpl/log_entry.en | 15 ++- tmpl/pb.en | 40 +----- tmpl/pb_entry.en | 33 ++--- tmpl/{header.en => skel.en} | 13 +- tmpl/st.en | 10 +- tmpl/us.en | 5 +- tmpl/us_entry.en | 10 +- 15 files changed, 332 insertions(+), 173 deletions(-) create mode 100644 lib/Plack/App/Gruntmaster/HTML.pm delete mode 100644 tmpl/footer.en rename tmpl/{header.en => skel.en} (79%) diff --git a/app.psgi b/app.psgi index 927653e..2a0c979 100644 --- a/app.psgi +++ b/app.psgi @@ -6,6 +6,7 @@ use Gruntmaster::Data; use Plack::App::Gruntmaster; use Plack::Builder; use Plack::Request; +use Plack::Util; use Digest::SHA qw/sha256/; use Log::Log4perl; use Tie::Hash::Expire; @@ -20,7 +21,6 @@ tie my %auth, 'Tie::Hash::Expire', {expire_seconds => 300}; sub authenticate { my ($user, $pass, $env) = @_; - say "Checking $user and $pass"; my $key = sha256 "$user:$pass"; $env->{'gruntmaster.user'} = $user; return 1 if exists $auth{$key}; @@ -28,6 +28,18 @@ sub authenticate { $auth{key} = 1; } +sub add_headers { + my $app = $_[0]; + sub { + my $resp = $app->($_[0]); + my $hdrs = Plack::Util::headers($resp->[1]); + $hdrs->set('Content-Security-Policy', CONTENT_SECURITY_POLICY); + $hdrs->set('Cache-Control', 'public, max-age=604800') if $_[0]->{PATH_INFO} =~ qr,^/static/,; + $resp->[1] = $hdrs->headers; + $resp; + } +} + Log::Log4perl->init('log.conf'); my $access_logger = Log::Log4perl->get_logger('access'); $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1; @@ -35,11 +47,10 @@ $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1; builder { enable 'AccessLog', format => ACCESSLOG_FORMAT, logger => sub { $access_logger->info(@_) }; enable 'ContentLength'; - enable Header => set => ['Content-Security-Policy', CONTENT_SECURITY_POLICY]; - enable_if { $_[0]->{PATH_INFO} =~ qr,^/static/,} Header => set => ['Cache-Control', 'public, max-age=604800']; + enable \&add_headers; enable 'Static', path => qr,^/static/,; enable 'Log4perl', category => 'plack'; - enable_if { shift->{HTTP_WWW_AUTHENTICATE} } 'Auth::Basic', authenticator => \&authenticate, realm => 'Gruntmaster 6000'; + enable_if { shift->{HTTP_AUTHORIZATION} } 'Auth::Basic', authenticator => \&authenticate, realm => 'Gruntmaster 6000'; enable_if { $_[0]->{PATH_INFO} eq '/ok' } sub { sub{ [200, [], []] }}; enable sub { my $app = $_[0]; sub { $_[0]->{'gruntmaster.dbic'} = $db; $app->($_[0]) } }; Plack::App::Gruntmaster->run_if_script diff --git a/css/custom.css b/css/custom.css index 1394354..3c62f01 100644 --- a/css/custom.css +++ b/css/custom.css @@ -8,7 +8,6 @@ footer{ width: 60em; margin: auto; margin-top: 6em; - white-space: pre-wrap; color: #777; } @@ -59,4 +58,4 @@ a.dropdown-toggle{ #clock{ float: right; margin-right: 1em; -} \ No newline at end of file +} diff --git a/lib/Plack/App/Gruntmaster.pm b/lib/Plack/App/Gruntmaster.pm index 3c989ac..3c26ecf 100644 --- a/lib/Plack/App/Gruntmaster.pm +++ b/lib/Plack/App/Gruntmaster.pm @@ -4,53 +4,24 @@ use 5.014000; use strict; our $VERSION = '5999.000_001'; -use Apache2::Authen::Passphrase qw/pwcheck pwset/; use CSS::Minifier::XS; +use Encode qw/encode decode/; use File::Slurp qw/read_file/; use JavaScript::Minifier::XS; - -use HTML::Template::Compiled; +use JSON::MaybeXS qw/encode_json/; use PerlX::Maybe; use Scope::Upper qw/unwind SUB UP/; +use Web::Simple; use Gruntmaster::Data; -use Web::Simple; -no warnings FATAL => 'all'; -use warnings; -no warnings::illegalproto; +use Plack::App::Gruntmaster::HTML; + +use warnings NONFATAL => 'all'; +no warnings 'illegalproto'; no if $] >= 5.017011, warnings => 'experimental::smartmatch'; ################################################## -sub read_templates { - my $name = shift; - - my %tmpl = map { m/\.(.+)$/; $1 => scalar read_file $_ } ; - my %arti = map { m/\.(.+)$/; $1 => scalar read_file $_ } ; - return %tmpl ? %tmpl : %arti -} - -my %header_templates = read_templates 'header'; -my %footer_templates = read_templates 'footer'; -my %templates; - -sub render { - my ($tmpl, $title, %params) = @_; - unless ($templates{$tmpl}) { - $templates{$tmpl} = { read_templates $tmpl }; - for my $lang (keys $templates{$tmpl}) { - my $header = $header_templates{$lang} =~ s/TITLE_GOES_HERE/$title/rg; - $templates{$tmpl}{$lang} = $header . $templates{$tmpl}{$lang}; - } - $templates{$tmpl}{$_} .= $footer_templates{$_} for keys $templates{$tmpl}; - - } - - my $htc = HTML::Template::Compiled->new(scalarref => \$templates{$tmpl}{en}, default_escape => 'HTML', use_perl => 1); - $htc->param(%params); - [200, ['Content-Type' => 'text/html'], [$htc->output]] -} - use constant USER_REGEX => qr/^\w{2,20}$/a; use constant CONTENT_TYPES => +{ @@ -74,7 +45,7 @@ use constant FORMAT_EXTENSION => { }; use constant NOT_FOUND => [404, ['Content-Type' => 'text/plain'], ['Not found']]; -use constant FORBIDDEN => [401, ['Content-Type' => 'text/plain', 'WWW-Authenticate' => ' Basic realm="Gruntmaster 6000"'], ['Forbidden']]; +use constant FORBIDDEN => [401, ['Content-Type' => 'text/plain', 'WWW-Authenticate' => 'Basic realm="Gruntmaster 6000"'], ['Forbidden']]; my $env; @@ -86,7 +57,7 @@ sub remote_user { $user } -sub admin { remote_user && remote_user->isadmin } +sub admin { remote_user && remote_user->admin } sub contest { db->contest ($_{contest}) } sub problem { db->problem ($_{problem}) } sub job { db->job ($_{job}) } @@ -102,6 +73,7 @@ sub response { } bless {template => $template, title => $title, params => $params}, __PACKAGE__.'::Response' } + sub forbid { return if !shift || admin; unwind FORBIDDEN, SUB UP @@ -149,8 +121,9 @@ sub dispatch_request{ response_filter { my ($r) = @_; return $r if ref $r ne 'Plack::App::Gruntmaster::Response'; - return [200, ['Content-Type' => 'application/json', 'X-Forever' => 1], [encode_json $r->{params}]] if $env->{HTTP_ACCEPT} =~ m,^\s*application/json\s*$,g; - render $r->{template}, $r->{title}, %{$r->{params}} + return [200, ['Content-Type' => 'application/json', 'X-Forever' => 1], [encode 'UTF-8', encode_json $r->{params}]] if $env->{HTTP_ACCEPT} =~ m,^\s*application/json\s*$,g; + my $ret = render $r->{template}, 'en', title => $r->{title}, %{$r->{params}}; + [200, ['Content-Type' => 'text/html'], [encode 'UTF-8', $ret]] }, }, @@ -169,8 +142,8 @@ sub dispatch_request{ sub (/us/) { response us => 'Users', {us => db->user_list} }, sub (/ct/ + ?:owner~) { response ct => 'Contests', db->contest_list(%_) }, - sub (/log/ + ?:contest~&:owner~&:page~&:problem~) { response log => 'Job list', {log => db->job_list(%_)} }, - sub (/pb/ + ?:owner~&:contest~) { response pb => 'Problems', db->problem_list(%_) }, + sub (/log/ + ?:contest~&:owner~&:page~&:problem~) { response log => 'Job list', {%{db->job_list(%_)}, maybe contest => $_{contest}} }, + sub (/pb/ + ?:owner~&:contest~) { response pb => 'Problems', {%{db->problem_list(%_)}, maybe contest => $_{contest}} }, sub (/us/:user) { response us_entry => user->name, db->user_entry($_{user}) }, sub (/ct/:contest) { response ct_entry => contest->name, db->contest_entry($_{contest}) }, @@ -182,11 +155,7 @@ sub dispatch_request{ }, sub (/) { redispatch_to '/index' }, - - sub (/:article) { - my $title = read_file "a/$_{article}.en.title"; - response $_{article} => $title, {}; - } + sub (/:article) { [200, ['Content-Type' => 'text/html'], [render_article $_{article}, 'en']] } }, sub (POST) { @@ -210,16 +179,16 @@ sub dispatch_request{ reply 'Password changed successfully'; }, - sub (/action/submit + %:problem=&:contest~&prog_format=&private~ + *source_code=) { + sub (/action/submit + %:problem=&:contest~&:prog_format=&:private~&:source_code~ + *:prog~) { forbid !remote_user; - return reply 'This contest has finished' if contest->is_finished; - return reply 'This contest has not yet started' if !admin && contest->is_pending; - return reply 'Maximum source size is 10KB' if $_{source_code}->size > 25 * 1024; + return reply 'This contest has finished' if contest && contest->is_finished; + return reply 'This contest has not yet started' if !admin && contest && contest->is_pending; + return reply 'Maximum source size is 10KB' if ($_{prog} ? $_{prog}->size : length $_{source_code}) > 10 * 1024; return reply 'You must wait 30 seconds between jobs' if !admin && time <= remote_user->lastjob + 30; remote_user->update({lastjob => time}); - my $prog = read_file $_{source_code}->path; - unlink $_{source_code}->path; + my $prog = $_{prog} ? read_file $_{prog}->path : $_{source_code}; + unlink $_{prog}->path if $_{prog}; db->jobs->create({ maybe contest => $_{contest}, maybe private => $_{private}, diff --git a/lib/Plack/App/Gruntmaster/HTML.pm b/lib/Plack/App/Gruntmaster/HTML.pm new file mode 100644 index 0000000..16ae617 --- /dev/null +++ b/lib/Plack/App/Gruntmaster/HTML.pm @@ -0,0 +1,204 @@ +package Plack::App::Gruntmaster::HTML; +use v5.14; +use parent qw/Exporter/; +our @EXPORT = qw/render render_article/; + +use File::Slurp qw/read_file/; +use HTML::Seamstress; +use POSIX qw//; +use Data::Dumper qw/Dumper/; + +sub ftime ($) { POSIX::strftime '%c', localtime shift } +sub literal ($) { HTML::Element::Library::super_literal shift // '' } + +sub HTML::Element::edit_href { + my ($self, $sub) = @_; + local $_ = $self->attr('href'); + $sub->(); + $self->attr(href => $_); +} + +sub HTML::Element::iter3 { + my ($self, $data, $code) = @_; + my $orig = $self; + my $prev = $orig; + for my $el (@$data) { + my $current = $orig->clone; + $code->($el, $current); + $prev->postinsert($current); + $prev = $current; + } + $orig->detach; +} + +sub HTML::Element::fid { shift->look_down(id => shift) } +sub HTML::Element::fclass { shift->look_down(class => shift) } + +sub HTML::Element::namedlink { + my ($self, $id, $name) = @_; + $name = $id unless $name =~ /[[:graph:]]/; + $self = $self->find('a'); + $self->edit_href(sub {s/id/$id/}); + $self->replace_content($name); +} + +sub render { + my ($tmpl, $lang, %args) = @_; + $lang //= 'en'; + my $meat = _render($tmpl, $lang, %args); + _render('skel', $lang, %args, meat => $meat) +} + +sub render_article { + my ($art, $lang) = @_; + $lang //= 'en'; + my $title = read_file "a/$art.$lang.title"; + my $meat = read_file "a/$art.$lang"; + _render('skel', $lang, title => $title , meat => $meat) +} + +sub _render { + my ($tmpl, $lang, %args) = @_; + my $builder = HTML::Seamstress->new; + $builder->ignore_unknown(0); + my $tree = $builder->parse_file("tmpl/$tmpl.$lang"); + $tree = $tree->guts unless $tmpl eq 'skel'; + $tree->defmap(smap => \%args); + my $process = __PACKAGE__->can("process_$tmpl"); + $process->($tree, %args) if $process; + $tree->as_HTML; +} + +sub process_skel { + my ($tree, %args) = @_; + $tree->content_handler( + title => $args{title}, + content => literal $args{meat}); +} + +sub process_us_entry { + my ($tree, %args) = @_; + $tree->fid($_)->attr('href', "/$_/?owner=$args{id}") for qw/log pb/; +} + +sub process_us { + my ($tree, %args) = @_; + my $item = $tree->fclass('list-group-item'); + $item->replace_with(map { + my $new = $item->clone; + $new->attr(href => $_->{id}); + $new->replace_content($_->{name} || $_->{id}); + $new + } @{$args{us}}); +} + +sub process_ct_entry { + my ($tree, %args) = @_; + $_->edit_href (sub {s/contest_id/$args{id}/}) for $tree->find('a'); + $tree->fid('links')->detach unless $args{started}; + $tree->content_handler( + start => ftime $args{start}, + stop => ftime $args{stop}, + description => literal $args{description}); +} + +sub process_ct { + my ($tree, %args) = @_; + my $iter = sub { + my ($data, $tr) = @_; + $data->{$_} = ftime $data->{$_} for qw/start stop/; + $tr->hashmap(class => $data, [qw/name owner/]); + $tr->fclass('name')->namedlink($data->{id}, $data->{name}); + $tr->fclass('owner')->namedlink($data->{owner}, $data->{owner_name}); + }; + $args{$_} ? $tree->fid($_)->find('tbody')->find('tr')->iter3($args{$_}, $iter) : $tree->fid($_)->detach for qw/running pending finished/; +} + +sub process_pb_entry { + my ($tree, %args) = @_; + $tree->fid('owner')->edit_href(sub{s/owner_id/$args{owner}/}); + $tree->fid('job_log')->edit_href(sub{s/problem_id/$args{id}/}); + $tree->content_handler( + statement => literal $args{statement}, + author => $args{author}, + owner => $args{owner_name} || $args{owner}); + if ($args{cansubmit}) { + $tree->look_down(name => 'problem')->attr(value => $args{id}); + my $contest = $tree->look_down(name => 'contest'); + $contest->attr(value => $args{contest}) if $args{contest}; + $contest->detach unless $args{contest} + } else { + $tree->fid('submit')->detach + } +} + +sub process_pb { + my ($tree, %args) = @_; + my $titer = sub { + my ($data, $tr) = @_; + $tr->set_child_content(class => 'author', $data->{author}); + $tr->fclass('name')->namedlink($data->{id}, $data->{name}); + $tr->fclass('name')->find('a')->edit_href(sub {$_ .= "?contest=$args{contest}"}) if $args{contest}; + $tr->fclass('owner')->namedlink($data->{owner}, $data->{owner_name}); + }; + my $iter = sub { + my ($data, $div) = @_; + $div->attr(id => $data); + $div->find('h2')->replace_content(ucfirst $data); + $div->find('tbody')->iter3($args{$data}, $titer); + }; + $tree->fid('beginner')->iter3([grep {$args{$_}} qw/beginner easy medium hard/], $iter); +} + +sub process_log_entry { + my ($tree, %args) = @_; + $args{errors} ? $tree->fid('errors')->find('pre')->replace_content($args{errors}) : $tree->fid('errors')->detach; + my $iter = sub { + my ($data, $tr) = @_; + $data->{time} = sprintf '%.4fs', $data->{time}; + $tr->defmap(class => $data); + $tr->fclass('result_text')->attr(class => "r$data->{result}") + }; + @{$args{results}} ? $tree->fid('results')->find('tbody')->find('tr')->iter3($args{results}, $iter) : $tree->fid('results')->detach; +} + +sub process_log { + my ($tree, %args) = @_; + my $iter = sub { + my ($data, $tr) = @_; + $tr->fclass('id')->namedlink($data->{id}); + $tr->fclass('problem')->namedlink($data->{problem}, $data->{problem_name}); + $tr->fclass('problem')->find('a')->edit_href(sub{$_ .= "?contest=$args{contest}"}) if $args{contest}; + $tr->fclass('date')->replace_content(ftime $data->{date}); + $tr->fclass('size')->namedlink("$data->{id}.$data->{extension}", sprintf "%.2fKB", $data->{size}/1024); + $tr->fclass('size')->attr('data-private', '') if $data->{private}; + $tr->fclass('owner')->namedlink($data->{owner}, $data->{owner_name}); + $tr->fclass('result_text')->replace_content($data->{result_text}); + $tr->fclass('result_text')->attr(class => "r$data->{result}"); + }; + $tree->find('table')->find('tbody')->find('tr')->iter3($args{log}, $iter); + $args{next_page} ? $tree->fclass('next')->namedlink($args{next_page}, 'Next') : $tree->fclass('next')->attr(class => 'next disabled'); + $args{previous_page} ? $tree->fclass('previous')->namedlink($args{previous_page}, 'Previous') : $tree->fclass('previous')->attr(class => 'previous disabled'); + $tree->fclass('current')->replace_content("Page $args{current_page} of $args{last_page}"); +} + +sub process_st { + my ($tree, %args) = @_; + $args{problems} //= []; + my $pbiter = sub { + my ($data, $th) = @_; + $th->attr(class => undef); + $th->namedlink($data->id, $data->name); + }; + $tree->fclass('problem')->iter3($args{problems}, $pbiter); + my $iter = sub { + my ($st, $tr) = @_; + $tr->set_child_content(class => 'rank', $st->{rank}); + $tr->set_child_content(class => 'score', $st->{score}); + $tr->fclass('user')->namedlink($st->{user}->id, $st->{user}->name); + my $pbscore = $tr->fclass('pbscore'); + $pbscore->detach unless $st->{problems}; + $pbscore->iter($pbscore => @{$st->{scores}}); + }; + $tree->find('tbody')->find('tr')->iter3($args{st}, $iter); +} diff --git a/tmpl/ct.en b/tmpl/ct.en index 9420708..31642df 100644 --- a/tmpl/ct.en +++ b/tmpl/ct.en @@ -1,41 +1,35 @@ - +

Running contests

+ -
NameStart dateStop dateOwner +
-<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{start}; %> -<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{stop}; %> - - +
Contest name......Owner name
- +
- +

Pending contests

+ -
NameStart dateStop dateOwner +
-<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{start}; %> -<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{stop}; %> - - +
Contest name......Owner name
- +
- +

Finished contests

+ -
NameStart dateStop dateOwner +
-<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{start}; %> -<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{stop}; %> - - +
Contest name......Owner name
- +
diff --git a/tmpl/ct_entry.en b/tmpl/ct_entry.en index 731872b..6f0a580 100644 --- a/tmpl/ct_entry.en +++ b/tmpl/ct_entry.en @@ -1,8 +1,12 @@ -Contest start time: <%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{start}; %>
-Contest stop time: <%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{stop}; %>

+

+
Contest start time
start
+
Contest stop time
stop
+
- +
description
-Problems
-Job log
-Standings + diff --git a/tmpl/footer.en b/tmpl/footer.en deleted file mode 100644 index c0f928d..0000000 --- a/tmpl/footer.en +++ /dev/null @@ -1,5 +0,0 @@ -
-Dilmom: Why don't you call your product the Gruntmaster 6000? -Dilbert: What kind of product do you see when you imagine a Gruntmaster 6000? -Dilmom: Well, it's a stripped-down version of the Gruntmaster 9000, of course. But it's software-upgradeable. -
diff --git a/tmpl/log.en b/tmpl/log.en index 1509168..eb4bf6f 100644 --- a/tmpl/log.en +++ b/tmpl/log.en @@ -1,17 +1,18 @@ - - + -
IDProblemDateSizeUserResult +
IDProblemDateSizeUserResult
- -<%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{date}; %> - data-private><%perl __OUT__ sprintf '%.2fKB', __CURRENT__->{size}/1024; %> - - +
Job ID +Problem name +Date +3.14KB +Owner name +
diff --git a/tmpl/log_entry.en b/tmpl/log_entry.en index adf6bfd..eb05db8 100644 --- a/tmpl/log_entry.en +++ b/tmpl/log_entry.en @@ -1,15 +1,16 @@ - +

Compiler output

-
- +

+

 
-
+

 
Results

 
+
 
-

 
 
Test numberResultTime
+
<%perl __OUT__ sprintf "%.4fs", __CURRENT__->{time}; %>
-
+

 

-
\ No newline at end of file
+

\ No newline at end of file
diff --git a/tmpl/pb.en b/tmpl/pb.en
index 35cfbd4..ae1a002 100644
--- a/tmpl/pb.en
+++ b/tmpl/pb.en
@@ -1,39 +1,11 @@
-
+

+

 
Beginner

 
-
-
NameAuthorOwner
-

-
-

-
-
-
-
Easy

-
-
-
NameAuthorOwner
-

-
-

-
+NameAuthorOwner
 
-
-
Medium

-
-
-
NameAuthorOwner
-

-
-

-
-
-
-
Hard

-
-
-
NameAuthorOwner
 

-
+
NameauthorOwner name
 

-
+

+

\ No newline at end of file
diff --git a/tmpl/pb_entry.en b/tmpl/pb_entry.en
index f3d0f75..8189d0b 100644
--- a/tmpl/pb_entry.en
+++ b/tmpl/pb_entry.en
@@ -1,35 +1,38 @@
 

 

-
+

 

 
 

 

-
Author
 

-
Owner
 

+
Author
 
author

+
Owner
 
owner

 

 
-Job log
+Job log
 
-
+

 
Submit solution

-

-
-
+
+
+
 
 

 
 

 

 
 
 

-
+

 

 

diff --git a/tmpl/header.en b/tmpl/skel.en
similarity index 79%
rename from tmpl/header.en
rename to tmpl/skel.en
index 0f5938b..a5a3fef 100644
--- a/tmpl/header.en
+++ b/tmpl/skel.en
@@ -1,11 +1,12 @@
 
-TITLE_GOES_HERE
+TITLE
 
 
 
 
 
 
+