From 594d53ba258320b2b98ec4413a808366237f5e40 Mon Sep 17 00:00:00 2001 From: Marius Gavrilescu Date: Wed, 23 Jul 2014 14:41:41 +0300 Subject: [PATCH] Refactoring, part I (Web::Simple) --- Makefile.PL | 8 +- app.psgi | 48 +--- lib/Gruntmaster/Page/Base.pm | 108 --------- lib/Gruntmaster/Page/Generic.pm | 181 -------------- lib/Gruntmaster/Page/Register.pm | 23 -- lib/Gruntmaster/Page/St.pm | 64 ----- lib/Gruntmaster/Page/Submit.pm | 49 ---- lib/Plack/App/Gruntmaster.pm | 403 ++++++++++++++++--------------- tmpl/ct_entry.en | 6 +- tmpl/log.en | 6 +- tmpl/us_entry.en | 4 +- 11 files changed, 234 insertions(+), 666 deletions(-) delete mode 100644 lib/Gruntmaster/Page/Base.pm delete mode 100644 lib/Gruntmaster/Page/Generic.pm delete mode 100644 lib/Gruntmaster/Page/Register.pm delete mode 100644 lib/Gruntmaster/Page/St.pm delete mode 100644 lib/Gruntmaster/Page/Submit.pm diff --git a/Makefile.PL b/Makefile.PL index 246d041..b59f56a 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -24,8 +24,6 @@ WriteMakefile( strict 0 warnings 0 - Apache2::Authen::Passphrase 0 - Apache2::AuthzCaps 0 CSS::Minifier::XS 0 File::Slurp 0 Gruntmaster::Data 0 @@ -35,8 +33,12 @@ WriteMakefile( JSON 0 Log::Log4perl 0 LWP::UserAgent 0 + PerlX::Maybe 0 Plack::Builder 0 - Plack::Request 0/, + Plack::Request 0 + Scope::Upper 0 + Tie::Hash::Expire 0 + Web::Simple 0/, }, META_MERGE => { dynamic_config => 0, diff --git a/app.psgi b/app.psgi index d9d42bf..927653e 100644 --- a/app.psgi +++ b/app.psgi @@ -2,54 +2,30 @@ use v5.14; no if $] >= 5.017011, warnings => 'experimental::smartmatch'; -use Apache2::Authen::Passphrase qw/pwcheck/; -use Apache2::AuthzCaps qw/hascaps/; use Gruntmaster::Data; use Plack::App::Gruntmaster; use Plack::Builder; use Plack::Request; use Digest::SHA qw/sha256/; use Log::Log4perl; +use Tie::Hash::Expire; +use constant AUTH_TIMEOUT => 5 * 60; use constant ACCESSLOG_FORMAT => '%{X-Forwarded-For}i|%h %u "%r" %>s %b "%{Referer}i" "%{User-agent}i"'; use constant CONTENT_SECURITY_POLICY => q,default-src 'none'; script-src 'self' www.google-analytics.com; style-src 'self'; img-src 'self'; connect-src 'self'; frame-src 'free.timeanddate.com',; -$Apache2::AuthzCaps::rootdir = $Apache2::Authen::Passphrase::rootdir; -my $word = qr,(\w+),a; my $db = Gruntmaster::Data->connect('dbi:Pg:'); -sub debug { - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; - $_[0]->{'psgix.logger'}->({qw/level debug message/ => $_[1]}) -} - -sub some_auth_required { - my $r = Plack::Request->new($_[0]); - return 1 if $_[0]->{'gruntmaster.reqadmin'} || $r->path eq '/action/passwd' || $r->path eq '/submit'; - return 1 if $r->path =~ m,^/ct/$word/pb/$word, && time < $db->contest($1)->stop; - '' -} - -my %authen_cache; +tie my %auth, 'Tie::Hash::Expire', {expire_seconds => 300}; sub authenticate { my ($user, $pass, $env) = @_; - my $cache_key = sha256 "$user:$pass"; - my $time = $authen_cache{$cache_key} // 0; - if ($time >= time - 300) { - return 1; - } else { - delete $authen_cache{$cache_key}; - } - - return unless eval { - pwcheck $user, $pass; - 1 - }; - $authen_cache{$cache_key} = time; - - return if $env->{'gruntmaster.reqadmin'} && $env->{'gruntmaster.reqadmin'} ne $user && !hascaps $user, 'gmadm'; - 1 + say "Checking $user and $pass"; + my $key = sha256 "$user:$pass"; + $env->{'gruntmaster.user'} = $user; + return 1 if exists $auth{$key}; + return unless $db->user($user) && $db->user($user)->check_passphrase($pass); + $auth{key} = 1; } Log::Log4perl->init('log.conf'); @@ -57,14 +33,14 @@ my $access_logger = Log::Log4perl->get_logger('access'); $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1; builder { - enable_if { $_[0]->{PATH_INFO} eq '/ok' } sub { sub{ [200, [], []] }}; 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 'Static', path => qr,^/static/,; enable 'Log4perl', category => 'plack'; - enable_if \&some_auth_required, 'Auth::Basic', authenticator => \&authenticate, realm => 'Gruntmaster 6000'; + enable_if { shift->{HTTP_WWW_AUTHENTICATE} } '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->to_app + Plack::App::Gruntmaster->run_if_script } diff --git a/lib/Gruntmaster/Page/Base.pm b/lib/Gruntmaster/Page/Base.pm deleted file mode 100644 index 1a68b3c..0000000 --- a/lib/Gruntmaster/Page/Base.pm +++ /dev/null @@ -1,108 +0,0 @@ -package Gruntmaster::Page::Base; - -use 5.014000; -use strict; -use warnings; -our $VERSION = '5999.000_001'; - -use File::Slurp qw/read_file/; -use HTML::Template::Compiled; - -################################################## - -sub read_templates { - my $root = 'tmpl'; - my $name = shift; - - map { m/\.(.+)$/; $1 => scalar read_file $_ } ; -} - -my %header_templates = read_templates 'header'; -my %footer_templates = read_templates 'footer'; - -sub header{ - my ($language, $title) = @_; - $header_templates{$language} =~ s/TITLE_GOES_HERE/$title/ger; -} - -sub footer{ - $footer_templates{$_[0]}; -} - -################################################## - -use POSIX (); -use List::Util (); -use LWP::UserAgent; -use Plack::Request (); -use feature (); - -my $ua = LWP::UserAgent->new; -my %templates; - -use Carp qw/cluck/; - -sub import_to { - my ($self, $caller, $name, $title) = @_; - - strict->import; - feature->import(':5.14'); - warnings->import; - File::Slurp->export_to_level(1, $caller, qw/read_file/); - List::Util->export_to_level(1, $caller, qw/sum/); - - no strict 'refs'; - *{"${caller}::ISA"} = [__PACKAGE__]; - *{"${caller}::VERSION"} = $VERSION; - *{"${caller}::strftime"} = \&POSIX::strftime; - *{"${caller}::debug"} = sub { - local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; - $_[0]->{'psgix.logger'}->({qw/level debug message/ => $_[1]}) - }; - *{"${caller}::db"} = sub { $_[0]->{'gruntmaster.dbic'} }; - *{"${caller}::reply"} = sub { [200, ['Content-Type' => 'text/plain', 'Cache-Control' => 'no-cache'], [ @_ ] ] }; - *{"${caller}::purge"} = sub { - return unless $ENV{PURGE_HOST}; - my $req = HTTP::Request->new(PURGE => "http://$ENV{PURGE_HOST}$_[0]"); - $ua->request($req) - }; - - if ($name) { - $templates{$caller} = { read_templates $name }; - $templates{$caller}{$_} = header ($_, $title) . $templates{$caller}{$_} for keys $templates{$caller}; - $templates{$caller}{$_} .= footer $_ for keys $templates{$caller}; - } -} - -sub import { - return unless $_[0] eq __PACKAGE__; - splice @_, 1, 0, scalar caller; - goto &import_to -} - -################################################## - -sub generate{ - my ($self, $lang, @args) = @_; - - my $htc = HTML::Template::Compiled->new(scalarref => \$templates{$self}{$lang}, default_escape => 'HTML', use_perl => 1); - $self->_generate($htc, $lang, @args); - my $out = $htc->output; - utf8::decode($out) for 1 .. 3; - utf8::encode($out); - my $vary = 'Accept-Language, ' . $self->vary; - [200, ['Content-Type' => 'text/html', 'Content-Language' => $_[1], 'Vary' => $vary, 'X-Forever' => 1, 'Cache-Control' => 'max-age=' . $self->max_age], [ $out ] ] -} - -sub _generate {} - -sub vary { '' } - -sub max_age { 60 } - -sub variants { - return [] unless exists $templates{$_[0]}; - [ map { [ $_, 1, 'text/html', undef, undef, $_, undef ]} keys $templates{$_[0]} ] -} - -1 diff --git a/lib/Gruntmaster/Page/Generic.pm b/lib/Gruntmaster/Page/Generic.pm deleted file mode 100644 index 15b887e..0000000 --- a/lib/Gruntmaster/Page/Generic.pm +++ /dev/null @@ -1,181 +0,0 @@ -package Gruntmaster::Page::Generic; - -use 5.014000; -use strict; -use warnings; -our $VERSION = '5999.000_001'; - -use Gruntmaster::Page::Base; -use JSON qw/encode_json decode_json/; -use Plack::Request; -use Sub::Name qw/subname/; - -use constant PAGE_SIZE => 10; - -sub putsym { - my ($key, $value) = @_; - no strict 'refs'; - subname $key => $value if ref $value eq 'CODE'; - *{"$key"} = $value; -} - -sub makepkg { - my ($pkg, $id, $title) = @_; - my $fn = $pkg =~ s,::,/,gr; - return if $INC{"$fn.pm"}; - $INC{"$fn.pm"} = 1; - Gruntmaster::Page::Base->import_to($pkg, $id, $title); - 1 -} - -sub list { - my ($thing, $lang, $env) = @_; - my %thing = %$thing; - my %params; - #debug $env => "Contest is $ct"; - $thing{makers} //= sub { db(shift)->resultset($thing{rsname}) }; - my $rs = $thing{makers}->($env); - $rs = $rs->search(undef, {order_by => 'me.id'}) unless $rs->is_ordered; - if (my $page = $env->{'gruntmaster.page'}) { - my $pages = int ($rs->count / PAGE_SIZE); - $params{default_page} = $page == -1; - $pages = 1 if $pages < 1; - $page = $pages if $page == -1; - @params{'page', 'pages'} = ($page, $pages); - $rs = $rs->search(undef, {offset => ($page - 1) * PAGE_SIZE, ($page == $pages ? () : (rows => PAGE_SIZE))}); - } - $rs = $rs->search(undef, { - exists $thing{prefetch} ? (prefetch => $thing{prefetch}) : (), - exists $thing{columns} ? (columns => $thing{columns}) : (), - }); - my @thing = map +{rs => $_, $_->get_columns}, $rs->all; - @thing = map { $thing{mangle}->($env); $_ } @thing if exists $thing{mangle}; - @thing = grep { $thing{choose}->() } @thing if exists $thing{choose}; - @thing = sort { $thing{sortby}->() } @thing if exists $thing{sortby}; - $thing{group} //= sub { $thing{id} }; - for (@thing) { - my $group = $thing{group}->(); - $params{$group} //= []; - push $params{$group}, $_ - } - wantarray ? %params : \%params -} - -sub entry { - my ($thing, $lang, $env, $id) = @_; - my %thing = %$thing; - debug $env => "Rsname is $thing{rsname} and id is $id"; - my %params = map {+ rs => $_, $_->get_columns } db($env)->resultset($thing{rsname})->find($id); - local $_ = \%params; - $thing{mangle}->($env) if exists $thing{mangle}; - wantarray ? %params : \%params -} - -sub headers ($) { ['Content-Type' => 'application/json', 'Cache-Control' => 'max-age=' . $_[0]->max_age] } - -sub create_thing { - my %thing = @_; - my $ucid = ucfirst $thing{id}; - my $pkg = "Gruntmaster::Page::$ucid"; - - putsym "${pkg}::_generate", sub { $_[1]->param(list \%thing, @_[2..$#_]) } if makepkg $pkg, @thing{qw/id title/}; - putsym "${pkg}::Entry::_generate", sub { $_[1]->param(entry \%thing, @_[2..$#_]) } if makepkg "${pkg}::Entry", "$thing{id}_entry", $thing{entry_title} // ''; - putsym "${pkg}::Read::generate", sub { [200, headers shift, [encode_json list \%thing, @_]] } if makepkg "${pkg}::Read"; - putsym "${pkg}::Entry::Read::generate", sub { [200, headers shift, [encode_json entry \%thing, @_]] } if makepkg "${pkg}::Entry::Read"; -} - -sub params; -sub makers (&); -sub choose (&); -sub sortby (&); -sub group (&); -sub mangle (&); -sub prefetch; -sub columns; - -sub thing (&){ - my %thing; - no strict 'refs'; - local *{"params"} = sub { @thing{qw/id rsname title entry_title/} = @_ }; - local *{"choose"} = sub { $thing{choose} = shift }; - local *{"sortby"} = sub { $thing{sortby} = shift }; - local *{"mangle"} = sub { $thing{mangle} = shift }; - local *{"group"} = sub { $thing{group} = shift }; - local *{"makers"} = sub { $thing{makers} = shift }; - local *{"prefetch"} = sub { $thing{prefetch} = \@_ }; - local *{"columns"} = sub { $thing{columns} = \@_ }; - use strict 'refs'; - - shift->(); - create_thing %thing -} - -################################################## - -thing { - params qw/us User Users/; - choose { $_->{name} =~ /\w/ }; - sortby { lc $a->{name} cmp lc $b->{name} }; -}; - -thing { - params qw/pb Problem Problems/; - prefetch 'owner'; - makers { - my $env = $_[0]; - my $db = db $env; - return $db->problems->search({owner => $env->{'gruntmaster.user'}}) if exists $env->{'gruntmaster.user'}; - return $db->problems->search({'contest_problems.contest' => $env->{'gruntmaster.contest'}}, {join => 'contest_problems'}) if exists $env->{'gruntmaster.contest'}; - $db->problems->search({-or => ['contest_problems.contest' => undef, 'contest.stop' => {'<=', time}], 'me.private' => 0}, {join => {'contest_problems' => 'contest'}, distinct => 1}); - }; - sortby { $a->{name} cmp $b->{name}}; - group { $_->{level} }; - mangle { - my $env = shift; - $_->{owner_name} = $_->{rs}->owner->name; - $_->{cansubmit} = $env->{'gruntmaster.contest'} ? time < db($env)->contest($env->{'gruntmaster.contest'})->stop : 1; - eval { - db($env)->opens->create({ - contest => $env->{'gruntmaster.contest'}, - problem => $_->{id}, - owner => $env->{REMOTE_USER}, - time => time, - }) - } if $env->{'gruntmaster.contest'} && time >= db($env)->contest($env->{'gruntmaster.contest'})->start; - }; -}; - -thing { - params qw/ct Contest Contests/; - prefetch 'owner'; - sortby { $b->{start} <=> $a->{start} }; - group { time < $_->{start} ? 'pending' : time > $_->{stop} ? 'finished' : 'running' }; - mangle { $_->{started} = time >= $_->{start}; $_->{owner_name} = $_->{rs}->owner->name }; -}; - -thing { - params qw/log Job/, 'Job log', 'Job '; - prefetch 'owner', 'problem'; - makers { - my $env = $_[0]; - my $db = db $env; - return $db->jobs->search({'me.owner' => $env->{'gruntmaster.user'}}) if exists $env->{'gruntmaster.user'}; - return $db->jobs->search({problem => $env->{'gruntmaster.problem'}}) if exists $env->{'gruntmaster.problem'}; - $db->jobs->search({contest => $env->{'gruntmaster.contest'}}) - }; - sortby { $b->{id} <=> $a->{id}}; - mangle { - my $env = shift; - $_->{results} &&= decode_json $_->{results}; - $_->{owner_name} = $_->{rs}->owner->name; - $_->{problem_name} = $_->{rs}->problem->name; - $_->{size} = length $_->{source}; - delete $_->{source}; - } -}; - -putsym 'Gruntmaster::Page::Pb::Entry::vary', sub { 'Authorization' }; -putsym 'Gruntmaster::Page::Pb::Entry::max_age', sub { 600 }; -putsym 'Gruntmaster::Page::Log::max_age', sub { 10 }; - -1 diff --git a/lib/Gruntmaster/Page/Register.pm b/lib/Gruntmaster/Page/Register.pm deleted file mode 100644 index ef2760f..0000000 --- a/lib/Gruntmaster/Page/Register.pm +++ /dev/null @@ -1,23 +0,0 @@ -package Gruntmaster::Page::Register; - -use Gruntmaster::Page::Base; -use Apache2::Authen::Passphrase qw/pwcheck pwset USER_REGEX/; - -sub generate{ - my ($self, $format, $env) = @_; - my $r = Plack::Request->new($env); - my ($username, $password, $confirm_password, $name, $email, $phone, $town, $university, $level) = map { die if length > 200; $_ } map {scalar $r->param($_)} qw/username password confirm_password name email phone town university level/; - - return reply 'Bad username. Allowed characters are letters, digits and underscores, and the username must be between 2 and 20 characters long.' unless $username =~ USER_REGEX; - return reply 'Username already in use' if -e "$Apache2::Authen::Passphrase::rootdir/$username.yml"; - return reply 'The two passwords do not match' unless $password eq $confirm_password; - return reply 'All fields are required' if grep { !length } $username, $password, $confirm_password, $name, $email, $phone, $town, $university, $level; - pwset $username, $password; - - db($env)->users->create({id => $username, name => $name, email => $email, phone => $phone, town => $town, university => $university, level => $level}); - - purge "/us/"; - reply 'Registered successfully'; -} - -1 diff --git a/lib/Gruntmaster/Page/St.pm b/lib/Gruntmaster/Page/St.pm deleted file mode 100644 index 9ed2a31..0000000 --- a/lib/Gruntmaster/Page/St.pm +++ /dev/null @@ -1,64 +0,0 @@ -package Gruntmaster::Page::St; - -use Gruntmaster::Page::Base st => 'Standings'; - -use constant LEVEL_VALUES => { - beginner => 100, - easy => 250, - medium => 500, - hard => 1000, -}; - -sub calc_score{ - my ($mxscore, $time, $tries, $totaltime) = @_; - my $score = $mxscore; - $time = 0 if $time < 0; - $time = 300 if $time > $totaltime; - $score = ($totaltime - $time) / $totaltime * $score; - $score -= $tries / 10 * $mxscore; - $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10; - int $score + 0.5 -} - -sub _generate{ - my ($self, $htc, $lang, $env) = @_; - #debug $env => "language is '$lang'"; - - my $ct = $env->{'gruntmaster.contest'} && db($env)->contest($env->{'gruntmaster.contest'}); - - my @problems = map { $_->problem } db($env)->contest_problems->search({contest => $ct && $ct->id}, {qw/join problem order_by problem.level/}); - my (%scores, %tries); - for my $job (db($env)->jobs->search({contest => $ct && $ct->id}, {order_by => 'id'})) { - - if ($ct) { - my $open = db($env)->opens->find($ct->id, $job->problem->id, $job->owner->id); - my $time = $job->date - ($open ? $open->time : $ct->start); - next if $time < 0; - my $value = $job->problem->value // LEVEL_VALUES->{$job->problem->level}; - my $factor = $job->result ? 0 : 1; - $factor = $1 / 100 if $job->result_text =~ /^(\d+ )/; - $scores{$job->owner->id}{$job->problem->id} = int ($factor * calc_score ($value, $time, $tries{$job->owner->id}{$job->problem->id}, $ct->stop - $ct->start)); - $tries{$job->owner->id}{$job->problem->id}++; - } else { - no warnings 'numeric'; - $scores{$job->owner->id}{$job->problem->id} = 0 + $job->result_text || ($job->result ? 0 : 100) - } - } - - my @st = sort { $b->{score} <=> $a->{score} or $a->{user}->id cmp $b->{user}->id} map { - my $user = $_; - +{ - user => db($env)->user($user), - score => sum (values $scores{$user}), - scores => [map { $scores{$user}{$_->id} // '-'} @problems], - problems => $ct, - } - } keys %scores; - - $st[0]->{rank} = 1; - $st[$_]->{rank} = $st[$_ - 1]->{rank} + ($st[$_]->{score} < $st[$_ - 1]->{score}) for 1 .. $#st; - $htc->param(problems => \@problems) if $ct; - $htc->param(st => \@st); -} - -1 diff --git a/lib/Gruntmaster/Page/Submit.pm b/lib/Gruntmaster/Page/Submit.pm deleted file mode 100644 index 0c42de9..0000000 --- a/lib/Gruntmaster/Page/Submit.pm +++ /dev/null @@ -1,49 +0,0 @@ -package Gruntmaster::Page::Submit; - -use Gruntmaster::Page::Base; - -use constant FORMAT_EXTENSION => { - C => 'c', - CPP => 'cpp', - MONO => 'cs', - JAVA => 'java', - PASCAL => 'pas', - PERL => 'pl', - PYTHON => 'py', -}; - -sub generate{ - my ($self, $frm, $env) = @_; - my $r = Plack::Request->new($env); - my ($problem, $format, $contest, $private, $prog) = map {scalar $r->param($_)} 'problem', 'prog_format', 'contest', 'private', 'source_code'; - $problem //= $env->{'gruntmaster.problem'}; - $contest //= $env->{'gruntmaster.contest'}; - my $upload = $r->upload('prog'); - if (defined $upload) { - my $temp = read_file $upload->path; - $prog = $temp if $temp - } - die if defined $contest && $contest !~ /^\w+$/ ; - die if defined $contest && (time > db($env)->contest($contest)->stop); - return reply 'A required parameter was not supplied' if grep { !defined } $problem, $format, $prog; - return reply 'Maximum source size is 10KB' if length $prog > 25 * 1024; - return reply 'You must wait 30 seconds between jobs' unless time > db($env)->user($r->user)->lastjob + 30; - db($env)->user($r->user)->update({lastjob => time}); - - db($env)->jobs->create({ - defined $contest ? (contest => $contest) : (), - date => time, - extension => FORMAT_EXTENSION->{$format}, - format => $format, - defined $private ? (private => $private) : (), - problem => $problem, - source => $prog, - owner => $r->user - }); - - $contest //= ''; - #PUBLISH 'jobs', "$contest.$job"; - [303, [Location => ($contest ? "/ct/$contest/log/" : '/log/')], ['']] -} - -1 diff --git a/lib/Plack/App/Gruntmaster.pm b/lib/Plack/App/Gruntmaster.pm index 8c8875d..3c989ac 100644 --- a/lib/Plack/App/Gruntmaster.pm +++ b/lib/Plack/App/Gruntmaster.pm @@ -2,66 +2,57 @@ package Plack::App::Gruntmaster; use 5.014000; use strict; -use warnings; -use parent qw/Plack::Component/; -no if $] >= 5.017011, warnings => 'experimental::smartmatch'; our $VERSION = '5999.000_001'; use Apache2::Authen::Passphrase qw/pwcheck pwset/; use CSS::Minifier::XS; use File::Slurp qw/read_file/; -use HTTP::Negotiate qw/choose/; use JavaScript::Minifier::XS; -use Plack::Request; -use Gruntmaster::Page::Generic; - -my %handlers; - -sub call { - my $env = $_[1]; - my $r = Plack::Request->new($env); - my @handlers = @{ $handlers{$r->method} // [] }; - for my $handler (@handlers) { - my ($re, $obj) = @$handler; - my @args; - next unless @args = $r->path =~ m/^$re$/a; - return $obj->($env, map { $_ // '' } @args); - } - if ($r->method eq 'GET' || $r->method eq 'HEAD') { - my $article = $r->path eq '/' ? '/index' : $r->path; - $article = substr $article, 1; - $article =~ tr,/,_,; - my @variants = grep { !/\.title$/ } ; - if (@variants) { - my $lang = choose [ map { [$_, 1, 'text/html', undef, undef, $_, undef] } map { /\.(.+)$/ } @variants ], $r->headers; - my $content = read_file "a/$article.$lang"; - my $title = read_file "a/$article.$lang.title"; - my $html = Gruntmaster::Page::Base::header($lang, $title) . $content . Gruntmaster::Page::Base::footer($lang); - return [200, ['Content-Type' => 'text/html', 'Content-Language' => $lang, 'Vary' => 'Accept-Language', 'X-Forever' => 1, 'Cache-Control' => 'max-age=300'], [$html] ] - } - } +use HTML::Template::Compiled; +use PerlX::Maybe; +use Scope::Upper qw/unwind SUB UP/; + +use Gruntmaster::Data; +use Web::Simple; +no warnings FATAL => 'all'; +use warnings; +no warnings::illegalproto; +no if $] >= 5.017011, warnings => 'experimental::smartmatch'; - [404, ['Content-Type' => 'text/plain'], ['Not found']] +################################################## + +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 } -sub get { push @{$handlers{GET }}, [ @_ ] } -sub post { push @{$handlers{POST}}, [ @_ ] } -sub db { $_[0]->{'gruntmaster.dbic'} } -sub reply { [200, ['Content-Type' => 'text/plain', 'Cache-Control' => 'no-cache'], [ @_ ] ] } -sub admin { 0 } - -sub old_handler { - my ($pkg) = @_; - $pkg = "Gruntmaster::Page::$pkg"; - eval "require $pkg" or die $@; - sub { - my ($env, @args) = @_; - my $format = choose $pkg->variants, Plack::Request->new($env)->headers; - $pkg->generate($format, $env, @args) +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 => +{ c => 'text/x-csrc', cpp => 'text/x-c++src', @@ -71,156 +62,180 @@ use constant CONTENT_TYPES => +{ pl => 'text/x-perl', py => 'text/x-python', }; + +use constant FORMAT_EXTENSION => { + C => 'c', + CPP => 'cpp', + MONO => 'cs', + JAVA => 'java', + PASCAL => 'pas', + PERL => 'pl', + PYTHON => 'py', +}; + use constant NOT_FOUND => [404, ['Content-Type' => 'text/plain'], ['Not found']]; -use constant FORBIDDEN => [403, ['Content-Type' => 'text/plain'], ['Forbidden']]; - -BEGIN{ - my $word = qr,(\w+),a; - my $number = qr,(\d+),a; - - get qr,/css/$word\.css, => sub { - my ($env, $theme) = @_; - return [404, ['Content-Type' => 'text/plain'], [ 'Not found' ]] unless -e "css/themes/$theme.css"; - my $css = read_file "css/themes/$theme.css"; - $css .= read_file $_ for ; - [200, ['Content-Type' => 'text/css', 'Cache-Control' => 'public, max-age=604800', 'X-Forever' => 1], [CSS::Minifier::XS::minify $css] ] - }; - - get qr,/js\.js, => sub { - my $js; - $js .= read_file $_ for ; - [200, ['Content-Type' => 'application/javascript', 'Cache-Control' => 'public, max-age=604800', 'X-Forever' => 1], [JavaScript::Minifier::XS::minify $js] ] - }; - - get qr,/log/src/$number\.$word, => sub { - my ($env, $job, $ext) = @_; - $job = db($env)->job($job); - return NOT_FOUND if $job->contest; - return FORBIDDEN if !admin && ($job->private || $job->problem->private); - [200, ['Content-Type' => CONTENT_TYPES->{$ext}, 'Cache-Control' => 'max-age=604800', 'X-Forever' => 1], [$job->source] ] - }; - - get qr,/ct/$word/log/src/$number\.$word, => sub { - my ($env, $ct, $job, $ext) = @_; - $job = db($env)->job($job); - $ct = db($env)->contest($ct); - return NOT_FOUND if $job->contest->id ne $ct->id; - return FORBIDDEN if !admin && ($job->private || !$ct->is_finished); - [200, ['Content-Type' => CONTENT_TYPES->{$ext}, 'Cache-Control' => 'max-age=604800', 'X-Forever' => 1], [$job->source] ] - }; - - get qr,/ct/$word/log/st, => sub { - my($env, $ct) = @_; - $env->{'gruntmaster.contest'} = $ct; - old_handler('St')->($env); - }; - - get qr,/us/, => old_handler 'Us'; - get qr,/us/$word, => old_handler 'Us::Entry'; - - get qr,/pb/, => old_handler 'Pb'; - - get qr,/us/$word/pb/, => sub { - my ($env, $us) = @_; - $env->{'gruntmaster.user'} = $us; - old_handler('Pb')->($env); - }; - - get qr,/ct/$word/pb/, => sub { - my ($env, $ct) = @_; - return FORBIDDEN if !admin && db($env)->contest($ct)->is_pending; - $env->{'gruntmaster.contest'} = $ct; - old_handler('Pb')->($env); - }; - - get qr,/pb/$word, => sub { - my ($env, $pb) = @_; - return NOT_FOUND if !db($env)->problem($pb)->is_in_archive; - return FORBIDDEN if !admin && db($env)->problem($pb)->private; - old_handler('Pb::Entry')->(@_); - }; - - get qr,/ct/$word/pb/$word, => sub{ - my ($env, $ct, $pb) = @_; - return NOT_FOUND if !db($env)->contest_problems->find($ct, $pb); - return FORBIDDEN if !admin && db($env)->contest($ct)->is_pending; - $env->{'gruntmaster.contest'} = $ct; - old_handler('Pb::Entry')->($env, $pb); - }; - - post qr,/pb/$word/submit, => sub { - my ($env, $pb) = @_; - return NOT_FOUND if !db($env)->problem($pb)->is_in_archive; - old_handler('Submit')->($env, $pb); - }; - - post qr,/ct/$word/pb/$word/submit, => sub { - my ($env, $ct, $pb) = @_; - return NOT_FOUND if !db($env)->contest_problems->find($ct, $pb); - return FORBIDDEN if !admin && db($env)->contest($ct)->is_pending; - $env->{'gruntmaster.contest'} = $ct; - old_handler('Submit')->($env, $pb); - }; - - get qr,/log/(?:page-$number)?, => sub { - my ($env, $page) = @_; - $env->{'gruntmaster.page'} = $page || -1; - old_handler('Log')->($env) - }; - - get qr,/ct/$word/log/(?:page-$number)?, => sub { - my ($env, $ct, $page) = @_; - return FORBIDDEN if !admin && db($env)->contest($ct)->is_pending; - $env->{'gruntmaster.contest'} = $ct; - $env->{'gruntmaster.page'} = $page || -1; - old_handler('Log')->($env) - }; - - get qr,/pb/$word/log/(?:page-$number)?, => sub { - my ($env, $pb, $page) = @_; - #return FORBIDDEN if !admin && db($pb)-> TODO - $env->{'gruntmaster.problem'} = $pb; - $env->{'gruntmaster.page'} = $page || -1; - old_handler('Log')->($env) - }; - - get qr,/us/$word/log/(?:page-$number)?, => sub { - my ($env, $us, $page) = @_; - $env->{'gruntmaster.user'} = $us; - $env->{'gruntmaster.page'} = $page || -1; - old_handler('Log')->($env); - }; - - get qr,/log/$number, => sub{ - my ($env, $job) = @_; - my $j = db($env)->job($job); - return FORBIDDEN if !admin && ($j->private || $j->problem->private || ($j->contest && !$j->contest->is_finished)); - old_handler('Log::Entry')->($env, $job); - }; - - get qr,/ct/, => old_handler 'Ct'; - - get qr,/ct/$word, => sub { - my ($env, $ct) = @_; - return FORBIDDEN if !admin && db($env)->contest($ct)->is_pending; - old_handler('Ct::Entry')->($env, $ct); - }; - - post qr,/action/passwd, => sub { - my ($env) = @_; - my $r = Plack::Request->new($env); - my ($oldpass, $newpass, $confirm) = map {scalar $r->param($_)} 'password', 'new_password', 'confirm_new_password'; - - return reply 'Incorrect password' unless eval { pwcheck $r->user, $oldpass; 1 }; - return reply 'The two passwords do not match' unless $newpass eq $confirm; - - pwset $r->user, $newpass; - reply 'Password changed successfully'; - }; - - post qr,/action/register, => old_handler 'Register'; +use constant FORBIDDEN => [401, ['Content-Type' => 'text/plain', 'WWW-Authenticate' => ' Basic realm="Gruntmaster 6000"'], ['Forbidden']]; + +my $env; + +sub db { $env->{'gruntmaster.dbic'} } + +sub remote_user { + my $user = $env->{'gruntmaster.user'}; + $user &&= db->user($user); + $user +} + +sub admin { remote_user && remote_user->isadmin } +sub contest { db->contest ($_{contest}) } +sub problem { db->problem ($_{problem}) } +sub job { db->job ($_{job}) } +sub user { db->user ($_{user}) } + +sub redirect { [301, ['X-Forever' => 1, 'Location' => $_[0]], []] } +sub reply { [200, ['Content-Type' => 'text/plain'], \@_] } +sub response { + my ($template, $title, $params) = @_; + unless ($params) { + $params = $title; + $title = 'No title'; + } + bless {template => $template, title => $title, params => $params}, __PACKAGE__.'::Response' +} +sub forbid { + return if !shift || admin; + unwind FORBIDDEN, SUB UP +} +sub dispatch_request{ + $env = $_[PSGI_ENV]; + sub (GET) { + sub (/css/:theme) { + my $theme = $_{theme}; + return NOT_FOUND unless -e "css/themes/$theme.css"; + my $css = read_file "css/themes/$theme.css"; + $css .= read_file $_ for ; + my @headers = ('X-Forever' => 1, 'Cache-Control' => 'public, max-age=604800', 'Content-Type' => 'text/css'); + [200, \@headers, [CSS::Minifier::XS::minify $css]] + }, + + sub (/js.js) { + my $js; + $js .= read_file $_ for ; + my @headers = ('X-Forever' => 1, 'Cache-Control' => 'public, max-age=604800', 'Content-Type' => 'application/javascript'); + [200, \@headers, [JavaScript::Minifier::XS::minify $js]] + }, + + sub (/src/:job) { + return NOT_FOUND if !job; + forbid job->private || job->problem->private || job->contest && job->contest->private; + my @headers = ('X-Forever' => 1, 'Cache-Control' => 'public, max-age=604800', 'Content-Type' => CONTENT_TYPES->{job->format}); + [200, \@headers, [job->source]] + }, + + sub (?:contest=) { + return NOT_FOUND if !contest; + forbid contest->is_pending; + response_filter { return shift } + }, + + sub (?:problem=) { + return NOT_FOUND if !problem; + forbid problem->is_private; + response_filter { return shift } + }, + + sub () { + 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}} + }, + }, + + sub (/st/) { + response st => 'Standings', { st => [db->standings] } + }, + + sub (/st/:contest) { + response st => 'Standings', { + st => [ db->standings($_{contest}) ], + problems => [map { $_->problem } contest->contest_problems] + } + }, + + sub (/ct/:contest/log/st) { redirect "/st/$_{contest}" }, + + 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 (/us/:user) { response us_entry => user->name, db->user_entry($_{user}) }, + sub (/ct/:contest) { response ct_entry => contest->name, db->contest_entry($_{contest}) }, + sub (/log/:job) { response log_entry => "Job $_{job}", db->job_entry($_{job}) }, + sub (/pb/:problem + ?:contest~) { + return NOT_FOUND if !contest && !problem->is_in_archive || contest && !db->contest_problems->find($_{contest}, $_{problem}); + forbid problem->is_private; + response pb_entry => problem->name, db->problem_entry($_{problem}, $_{contest}, remote_user && remote_user->id); + }, + + sub (/) { redispatch_to '/index' }, + + sub (/:article) { + my $title = read_file "a/$_{article}.en.title"; + response $_{article} => $title, {}; + } + }, + + sub (POST) { + sub (/action/register + %:username=&:password=&:confirm_password=&:name=&:email=&:phone=&:town=&:university=&:level=) { + return reply 'Parameter too long' if grep { length > 200 } values %_; + return reply 'Bad username. Allowed characters are letters, digits and underscores, and the username must be between 2 and 20 characters long.' unless $_{username} =~ USER_REGEX; + return reply 'Username already in use' if db->user($_{username}); + return reply 'The two passwords do not match' unless $_{password} eq $_{confirm_password}; + + db->users->create({id => $_{username}, name => $_{name}, email => $_{email}, phone => $_{phone}, town => $_{town}, university => $_{university}, level => $_{level}}); + db->user($_{username})->set_passphrase($_{password}); + + reply 'Registered successfully'; + }, + + sub (/action/passwd + %:password=&:new_password=&:confirm_new_password=) { + forbid !remote_user; + return reply 'Incorrect password' unless remote_user->check_passphrase($_{password}); + return reply 'The two passwords do not match' unless $_{new_password} eq $_{confirm_new_password}; + remote_user->set_passphrase($_{new_password}); + reply 'Password changed successfully'; + }, + + sub (/action/submit + %:problem=&:contest~&prog_format=&private~ + *source_code=) { + 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 '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; + db->jobs->create({ + maybe contest => $_{contest}, + maybe private => $_{private}, + date => time, + extension => FORMAT_EXTENSION->{$_{prog_format}}, + format => $_{prog_format}, + problem => $_{problem}, + source => $prog, + owner => remote_user->id, + }); + + redirect $_{contest} ? "/log/?contest=$_{contest}" : '/log/'; + } + } } + 1; __END__ diff --git a/tmpl/ct_entry.en b/tmpl/ct_entry.en index 0ad32c9..731872b 100644 --- a/tmpl/ct_entry.en +++ b/tmpl/ct_entry.en @@ -3,6 +3,6 @@ Contest stop time: <%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__-> -Problems
-Job log
-Standings +Problems
+Job log
+Standings diff --git a/tmpl/log.en b/tmpl/log.en index 14f6a89..1509168 100644 --- a/tmpl/log.en +++ b/tmpl/log.en @@ -5,13 +5,13 @@ <%perl __OUT__ POSIX::strftime '%c', localtime __CURRENT__->{date}; %> - data-private><%perl __OUT__ sprintf '%.2fKB', __CURRENT__->{size}/1024; %> + data-private><%perl __OUT__ sprintf '%.2fKB', __CURRENT__->{size}/1024; %>
    -<%perl if (__CURRENT__->{page} > 1) { %>
diff --git a/tmpl/us_entry.en b/tmpl/us_entry.en index 69d95da..4d1a97a 100644 --- a/tmpl/us_entry.en +++ b/tmpl/us_entry.en @@ -4,5 +4,5 @@
Level
-Job log
-Owned problems +Job log
+Owned problems -- 2.30.2