2 package Gruntmaster
::Data
;
4 # Created by DBIx::Class::Schema::Loader
5 # DO NOT MODIFY THE FIRST PART OF THIS FILE
10 use base
'DBIx::Class::Schema';
12 __PACKAGE__
->load_namespaces;
15 # Created by DBIx::Class::Schema::Loader v0.07039 @ 2014-03-05 13:11:39
16 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:dAEmtAexvUaNXLgYz2rNEg
18 use parent qw
/Exporter/;
19 our $VERSION = '5999.000_013';
20 our @EXPORT = qw
/purge/; ## no critic (ProhibitAutomaticExportation)
22 use Lingua
::EN
::Inflect qw
/PL_N/;
23 use JSON
::MaybeXS qw
/decode_json/;
25 use PerlX
::Maybe qw
/maybe/;
26 use Sub
::Name qw
/subname/;
27 use Class
::Method
::Modifiers qw
/around/;
31 use List
::Util qw
/sum/;
34 use constant CONTEST_PUBLIC_COLUMNS
=> [qw
/id name description start stop owner/];
35 use constant PROBLEM_PUBLIC_COLUMNS
=> [qw
/id author writer level name owner private timeout olimit value/];
36 use constant USER_PUBLIC_COLUMNS
=> [qw
/id admin name town university country level/];
37 use constant JOBS_PER_PAGE
=> 50;
40 our ($name, $sub) = @_;
41 no strict
'refs'; ## no critic (Strict)
42 *$name = subname
$name => $sub
46 for my $rs (qw
/contest contest_problem job open limit problem user problem_status contest_status/) {
47 my $rsname = ucfirst $rs;
48 $rsname =~ s/_([a-z])/\u$1/gs;
49 dynsub PL_N
($rs) => sub { $_[0]->resultset($rsname) };
50 dynsub
$rs => sub { $_[0]->resultset($rsname)->find($_[1]) };
55 user_list_sth
=> 'SELECT * FROM user_list LIMIT 200',
56 user_entry_sth
=> 'SELECT * FROM user_data WHERE id = ?',
58 problem_status_sth
=> 'SELECT problem,solved FROM problem_status WHERE owner = ?',
59 contest_status_sth
=> 'SELECT contest,score,rank FROM contest_status WHERE owner = ?',
61 contest_list_sth
=> 'SELECT * FROM contest_entry',
62 contest_entry_sth
=> 'SELECT * FROM contest_entry WHERE id = ?',
63 contest_full_sth
=> 'SELECT * FROM contests WHERE id = ?',
64 contest_problems_sth
=> 'SELECT problem FROM contest_problems JOIN problems pb ON problem=pb.id WHERE contest = ? ORDER BY pb.value',
65 contest_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
66 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
68 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
69 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
70 problem_values_sth
=> 'SELECT id,value FROM problems',
72 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
73 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
76 around
connect => sub {
78 my $self = $orig->(@_);
79 $self->{dbh
} = DBI
->connect($_[1]);
80 $self->{dbis
} = DBIx
::Simple
->new($self->{dbh
});
81 $self->{dbis
}->keep_statements = 100;
88 my ($self, $stat, @extra) = @_;
89 $self->{dbis
}->query($statements{$stat} // $stat, @extra)
92 my (%name_cache, %name_cache_time);
93 use constant NAME_CACHE_MAX_AGE
=> 5;
96 my ($self, $table, $id) = @_;
97 $name_cache_time{$table} //= 0;
98 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
99 $name_cache_time{$table} = time;
100 $name_cache{$table} = {};
101 $name_cache{$table} = $self->{dbis
}->select($table, 'id,name')->map;
104 $name_cache{$table}{$id}
109 my ($self, $el) = @_;
110 if (ref $el eq 'ARRAY') {
111 $self->add_names($_) for @
$el
113 for my $object (qw
/contest owner problem/) {
114 my $table = $object eq 'owner' ?
'users' : "${object}s";
115 $el->{"${object}_name"} = $self->object_name($table, $el->{$object}) if defined $el->{$object}
124 my $rs = $self->users->search(undef, {columns
=> USER_PUBLIC_COLUMNS
} );
125 my (%solved, %attempted, %contests);
127 for my $row ($self->problem_statuses->all) {
128 $solved {$row->rawowner}++ if $row->solved;
129 $attempted{$row->rawowner}++ unless $row->solved;
131 $contests{$_->rawowner}++ for $self->contest_statuses->all;
133 my @users = sort { $b->{solved
} <=> $a->{solved
} or $b->{attempted
} <=> $a->{attempted
} } ## no critic (ProhibitReverseSort)
137 solved
=> ($solved{$id} // 0),
138 attempted
=> ($attempted{$id} // 0),
139 contests
=> ($contests{$id} // 0) }
141 @users = @users[0 .. 199] if @users > 200;
145 sub user_entry_orig
{
146 my ($self, $id) = @_;
147 my $user = $self->users->find($id, {columns
=> USER_PUBLIC_COLUMNS
, prefetch
=> [qw
/problem_statuses contest_statuses/]});
148 my @problems = map { {problem
=> $_->get_column('problem'), solved
=> $_->solved} } $user->problem_statuses->search(undef, {order_by
=> 'problem'});
149 my @contests = map { {contest
=> $_->contest->id, contest_name
=> $_->contest->name, rank
=> $_->rank, score
=> $_->score} } $user->contest_statuses->search(undef, {prefetch
=> 'contest', order_by
=> 'contest.start DESC'});
150 +{ $user->get_columns, problems
=> \
@problems, contests
=> \
@contests }
155 scalar $self->query('user_list_sth')->hashes
159 my ($self, $id) = @_;
160 my $ret = $self->query('user_entry_sth', $id)->hash;
161 $ret->{problems
} = $self->query('problem_status_sth', $id)->hashes;
162 $ret->{contests
} = $self->query('contest_status_sth', $id)->hashes;
164 $self->add_names($ret->{problems
});
165 $self->add_names($ret->{contests
});
169 sub problem_list_orig
{
170 my ($self, %args) = @_;
171 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
172 push @columns, 'solution' if $args{solution
} && $args{contest
} && !$self->contest($args{contest
})->is_running;
173 my $rs = $self->problems->search(undef, {order_by
=> 'me.name', columns
=> \
@columns, prefetch
=> 'owner'});
174 $rs = $rs->search({'private' => 0}) unless $args{contest
} || $args{private
};
175 $rs = $rs->search({'contest_problems.contest' => $args{contest
}}, {join => 'contest_problems'}) if $args{contest
};
176 $rs = $rs->search({'me.owner' => $args{owner
}}) if $args{owner
};
178 $params{contest
} = $args{contest
} if $args{contest
} && $self->contest($args{contest
})->is_running;
180 $params{$_->level} //= [];
181 push @
{$params{$_->level}}, {$_->get_columns, owner_name
=> $_->owner->name} ;
187 my ($self, %args) = @_;
188 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
189 push @columns, 'solution' if $args{solution
};
191 $where{private
} = 0 unless $args{contest
} || $args{private
};
192 $where{'cp.contest'} = $args{contest
} if $args{contest
};
193 $where{owner
} = $args{owner
} if $args{owner
};
195 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
196 my $ret = $self->{dbis
}->select(\
$table, \
@columns, \
%where, 'name')->hashes;
197 $self->add_names($ret);
201 $params{$_->{level
}} //= [];
202 push @
{$params{$_->{level
}}}, $_
207 sub problem_entry_orig
{
208 my ($self, $id, $contest, $user) = @_;
209 my $running = $contest && $self->contest($contest)->is_running;
210 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
211 push @columns, 'statement';
212 push @columns, 'solution' unless $running;
213 my $pb = $self->problems->find($id, {columns
=> \
@columns, prefetch
=> 'owner'});
214 my @limits = map { +{
215 format
=> $_->format,
216 timeout
=> $_->timeout,
217 } } $self->limits->search({problem
=> $id});
219 $open = $self->opens->find_or_create({
225 $contest &&= $self->contest($contest);
228 @limits ?
(limits
=> \
@limits) : (),
229 owner_name
=> $pb->owner->name,
230 cansubmit
=> !$contest || !$contest->is_finished,
232 contest_start
=> $contest->start,
233 contest_stop
=> $contest->stop,
234 open_time
=> $open->time
240 my ($self, $id, $contest, $user) = @_;
241 $contest &&= $self->contest_entry($contest);
242 my $ret = $self->query(problem_entry_sth
=> $id)->hash;
243 $self->add_names($ret);
244 my $limits = $self->query(limits_sth
=> $id)->hashes;
245 $ret->{limits
} = $limits if @
$limits;
248 $ret->{contest_start
} = $contest->{start
};
249 $ret->{contest_stop
} = $contest->{stop
};
255 sub contest_list_orig
{
256 my ($self, %args) = @_;
257 my $rs = $self->contests->search(undef, {columns
=> CONTEST_PUBLIC_COLUMNS
, order_by
=> {-desc
=> 'start'}, prefetch
=> 'owner'});
258 $rs = $rs->search({owner
=> $args{owner
}}) if $args{owner
};
261 my $state = $_->is_pending ?
'pending' : $_->is_running ?
'running' : 'finished';
262 $params{$state} //= [];
263 push @
{$params{$state}}, { $_->get_columns, owner_name
=> $_->owner->name };
268 sub contest_entry_orig
{
269 my ($self, $id) = @_;
270 my $ct = $self->contests->find($id,{columns
=> CONTEST_PUBLIC_COLUMNS
});
271 +{ $ct->get_columns, started
=> !$ct->is_pending, finished
=> $ct->is_finished, owner_name
=> $ct->owner->name }
276 my $ret = $self->query('contest_list_sth')->hashes;
277 $self->add_names($ret);
281 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
283 push @
{$ret{$state}}, $_;
290 my ($self, $id) = @_;
291 my $ret = $self->query(contest_entry_sth
=> $id)->hash;
292 $self->add_names($ret);
296 my ($self, $id) = @_;
297 scalar $self->query(contest_full_sth
=> $id)->hash;
300 sub contest_has_problem
{
301 my ($self, $contest, $problem) = @_;
302 $self->query('contest_has_problem_sth')->flat
306 my ($self, %args) = @_;
308 my $rs = $self->jobs->search(undef, {order_by
=> {-desc
=> 'me.id'}, prefetch
=> ['problem', 'owner', 'contest'], rows
=> JOBS_PER_PAGE
, page
=> $args{page
}});
309 $rs = $rs->search({contest
=> $args{contest
} || undef}) if exists $args{contest
};
310 $rs = $rs->search({'me.private'=> 0}) unless $args{private
};
311 $rs = $rs->search({'me.owner' => $args{owner
}}) if $args{owner
};
312 $rs = $rs->search({problem
=> $args{problem
}}) if $args{problem
};
313 $rs = $rs->search({result
=> $args{result
}}) if defined $args{result
};
316 my %params = $_->get_columns;
317 $params{owner_name
} = $_->owner->name;
318 $params{problem_name
} = $_->problem->name;
319 $params{contest_name
} = $_->contest->name if $params{contest
};
320 $params{results
} &&= decode_json
$params{results
};
321 $params{size
} = length $params{source
};
322 delete $params{source
};
325 current_page
=> $rs->pager->current_page,
326 maybe previous_page
=> $rs->pager->previous_page,
327 maybe next_page
=> $rs->pager->next_page,
328 maybe last_page
=> $rs->pager->last_page,
333 my ($self, $id) = @_;
334 my $job = $self->jobs->find($id, {prefetch
=> ['problem', 'owner', 'contest']});
335 my %params = $job->get_columns;
336 $params{owner_name
} = $job->owner->name;
337 $params{problem_name
} = $job->problem->name;
338 $params{contest_name
} = $job->contest->name if $params{contest
};
339 $params{results
} &&= decode_json
$params{results
};
340 $params{size
} = length $params{source
};
341 delete $params{source
};
346 my ($self, %args) = @_;
349 maybe contest
=> $args{contest
},
350 maybe owner
=> $args{owner
},
351 maybe problem
=> $args{problem
},
352 maybe result
=> $args{result
},
354 $where{private
} = 0 unless $args{private
};
356 my $rows = $self->{dbis
}->select('job_entry', 'COUNT(*)', \
%where)->list;
357 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
358 my ($stmt, @bind) = $self->{dbis
}->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
359 my $jobs = $self->{dbis
}->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
362 current_page
=> $args{page
},
365 $self->add_names($ret{log});
366 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
367 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
373 my ($self, $id) = @_;
374 my $ret = $self->query(job_entry_sth
=> $id)->hash;
375 $ret->{results
} &&= decode_json
$ret->{results
};
376 $self->add_names($ret);
380 my ($self, $id) = @_;
381 scalar $self->query(job_full_sth
=> $id)->hash
385 my ($self, %args) = @_;
386 $self->{dbis
}->update('users', {lastjob
=> time});
388 scalar $self->{dbis
}->insert('jobs', \
%args, {returning
=> 'id'})->list
392 my ($mxscore, $time, $tries, $totaltime) = @_;
393 my $score = $mxscore;
394 $time = 0 if $time < 0;
395 $time = 300 if $time > $totaltime;
396 $score = ($totaltime - $time) / $totaltime * $score;
397 $score -= $tries / 10 * $mxscore;
398 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
403 my ($self, $ct) = @_;
404 $ct = $self->contest_entry($ct);
406 my @problems = $self->query(contest_problems_sth
=> $ct->{id
})->flat;
407 my $pblist = $self->problem_list;
408 my %values = $self->query('problem_values_sth')->map;
409 # $values{$_} = $values{$_}->{value} for keys %values;
411 my (%scores, %tries, %opens);
412 my $opens = $self->query(opens_sth
=> $ct->{id
});
413 while ($opens->into(my ($problem, $owner, $time))) {
414 $opens{$problem, $owner} = $time;
417 my $jobs = $self->{dbis
}->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
419 while (my $job = $jobs->hash) {
420 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
421 my $time = $job->{date
} - $open;
423 my $value = $values{$job->{problem
}};
424 my $factor = $job->{result
} ?
0 : 1;
425 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
426 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
429 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
433 user_name
=> $self->object_name(users
=> $user),
434 score
=> sum
(values %{$scores{$user}}),
435 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
439 $st[0]->{rank
} = 1 if @st;
440 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
443 problems
=> [map { [ $_, $self->object_name(problems
=> $_)] } @problems],
447 sub update_status_orig
{
449 my @jobs = $self->jobs->search({'me.private' => 0}, {cache
=> 1, prefetch
=> 'problem', order_by
=> 'me.id'})->all;
454 my $pb = $_->get_column('problem');
455 $private{$pb} //= $_->problem->private;
456 next if $private{$pb};
457 $hash{$pb, $_->get_column('owner')} = [$_->id, $_->result ?
0 : 1];
460 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
462 my @contest_statuses = map {
463 my $contest = $_->id;
464 map { [$contest, $_->{user
}, $_->{score
}, $_->{rank
}] } $_->standings
465 } $self->contests->all;
468 $self->problem_statuses->delete;
469 $self->problem_statuses->populate([[qw
/problem owner job solved/], @problem_statuses]);
470 $self->contest_statuses->delete;
471 $self->contest_statuses->populate([[qw
/contest owner score rank/], @contest_statuses]);
479 my $jobs = $self->{dbis
}->select('jobs', 'id,owner,problem,result', {}, 'id');
482 while ($jobs->into(my ($id, $owner, $problem, $result))) {
483 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
486 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
488 my @contest_statuses = map {
490 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{$self->standings($ct)->{st
}}
491 } $self->{dbis
}->select('contests', 'id')->flat;
493 $self->{dbis
}->begin;
494 $self->{dbis
}->delete('problem_status');
495 $self->{dbis
}->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
496 $self->{dbis
}->delete('contest_status');
497 $self->{dbis
}->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
498 $self->{dbis
}->commit
501 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
502 my $ht = HTTP
::Tiny
->new;
505 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
516 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
520 my $db = Gruntmaster::Data->connect('dbi:Pg:');
522 my $problem = $db->problem('my_problem');
523 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
524 $problem->rerun; # And rerun all jobs for this problem
528 my $contest = $db->contests->create({ # Create a new contest
530 name => 'My Awesome Contest',
534 $db->contest_problems->create({ # Add a problem to the contest
535 contest => 'my_contest',
536 problem => 'my_problem',
539 say 'The contest has not started yet' if $contest->is_pending;
543 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
544 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
548 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
550 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
556 Equivalent to C<< $schema->resultset('Contest') >>
558 =item contest_problems
560 Equivalent to C<< $schema->resultset('ContestProblem') >>
564 Equivalent to C<< $schema->resultset('Job') >>
568 Equivalent to C<< $schema->resultset('Problem') >>
572 Equivalent to C<< $schema->resultset('User') >>
576 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
580 Equivalent to C<< $schema->resultset('Job')->find($id) >>
584 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
588 Equivalent to C<< $schema->resultset('User')->find($id) >>
592 Returns a list of users as an arrayref containing hashrefs.
594 =item user_entry($id)
596 Returns a hashref with information about the user $id.
598 =item problem_list([%args])
600 Returns a list of problems grouped by level. A hashref with levels as keys.
602 Takes the following arguments:
608 Only show problems owned by this user
612 Only show problems in this contest
616 =item problem_entry($id, [$contest, $user])
618 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
620 =item contest_list([%args])
622 Returns a list of contests grouped by state. A hashref with the following keys:
628 An arrayref of hashrefs representing pending contests
632 An arrayref of hashrefs representing running contests
636 An arrayref of hashrefs representing finished contests
640 Takes the following arguments:
646 Only show contests owned by this user.
650 =item contest_entry($id)
652 Returns a hashref with information about the contest $id.
654 =item job_list([%args])
656 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
662 Only show jobs submitted by this user.
666 Only show jobs submitted in this contest.
670 Only show jobs submitted for this problem.
674 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
680 Returns a hashref with information about the job $id.
686 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
688 =head1 COPYRIGHT AND LICENSE
690 Copyright (C) 2014 by Marius Gavrilescu
692 This library is free software; you can redistribute it and/or modify
693 it under the same terms as Perl itself, either Perl version 5.18.1 or,
694 at your option, any later version of Perl 5 you may have available.