1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
7 our @EXPORT = qw
/purge user_list user_entry problem_list problem_entry contest_list contest_entry contest_full contest_has_problem job_list job_entry job_full create_job standings update_status/; ## no critic (ProhibitAutomaticExportation)
9 use JSON
::MaybeXS qw
/decode_json/;
11 use PerlX
::Maybe qw
/maybe/;
15 use List
::Util qw
/sum/;
18 use constant PROBLEM_PUBLIC_COLUMNS
=> [qw
/id author writer level name owner private timeout olimit value/];
19 use constant JOBS_PER_PAGE
=> 50;
22 user_list_sth
=> 'SELECT * FROM user_list LIMIT 200',
23 user_entry_sth
=> 'SELECT * FROM user_data WHERE id = ?',
25 problem_status_sth
=> 'SELECT problem,solved FROM problem_status WHERE owner = ?',
26 contest_status_sth
=> 'SELECT contest,score,rank FROM contest_status WHERE owner = ?',
28 contest_list_sth
=> 'SELECT * FROM contest_entry',
29 contest_entry_sth
=> 'SELECT * FROM contest_entry WHERE id = ?',
30 contest_full_sth
=> 'SELECT * FROM contests WHERE id = ?',
31 contest_problems_sth
=> 'SELECT problem FROM contest_problems JOIN problems pb ON problem=pb.id WHERE contest = ? ORDER BY pb.value',
32 contest_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
33 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
35 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
36 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
37 problem_values_sth
=> 'SELECT id,value FROM problems',
39 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
40 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
46 $db = DBIx
::Simple
->new(@_);
47 $db->keep_statements = 100;
53 my ($stat, @extra) = @_;
54 $db->query($statements{$stat}, @extra)
57 my (%name_cache, %name_cache_time);
58 use constant NAME_CACHE_MAX_AGE
=> 5;
61 my ($table, $id) = @_;
62 $name_cache_time{$table} //= 0;
63 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
64 $name_cache_time{$table} = time;
65 $name_cache{$table} = {};
66 $name_cache{$table} = $db->select($table, 'id,name')->map;
69 $name_cache{$table}{$id}
73 sub add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
75 if (ref $el eq 'ARRAY') {
76 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
78 for my $object (qw
/contest owner problem/) {
79 my $table = $object eq 'owner' ?
'users' : "${object}s";
80 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
87 sub user_list
{ +{us
=> scalar query
('user_list_sth')->hashes} }
91 my $ret = query
('user_entry_sth', $id)->hash;
92 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
93 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
100 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
101 push @columns, 'solution' if $args{solution
};
103 $where{private
} = 0 unless $args{contest
} || $args{private
};
104 $where{'cp.contest'} = $args{contest
} if $args{contest
};
105 $where{owner
} = $args{owner
} if $args{owner
};
107 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
108 my $ret = add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes;
112 $params{$_->{level
}} //= [];
113 push @
{$params{$_->{level
}}}, $_
119 my ($id, $contest) = @_;
120 $contest = contest_entry
($contest) if $contest;
121 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
122 my $limits = query
(limits_sth
=> $id)->hashes;
123 $ret->{limits
} = $limits if @
$limits;
126 $ret->{contest_start
} = $contest->{start
};
127 $ret->{contest_stop
} = $contest->{stop
};
128 delete $ret->{solution
}
135 my $ret = add_names query
('contest_list_sth')->hashes;
139 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
141 push @
{$ret{$state}}, $_;
149 add_names query
(contest_entry_sth
=> $id)->hash;
154 scalar query
(contest_full_sth
=> $id)->hash;
157 sub contest_has_problem
{
158 my ($contest, $problem) = @_;
159 query
('contest_has_problem_sth', $contest, $problem)->flat
166 maybe contest
=> $args{contest
},
167 maybe owner
=> $args{owner
},
168 maybe problem
=> $args{problem
},
169 maybe result
=> $args{result
},
171 $where{private
} = 0 unless $args{private
};
173 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
174 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
175 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
176 my $jobs = $db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
178 log => add_names
$jobs,
179 current_page
=> $args{page
},
182 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
183 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
190 my $ret = add_names query
(job_entry_sth
=> $id)->hash;
191 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
197 scalar query
(job_full_sth
=> $id)->hash
202 $db->update('users', {lastjob
=> time});
204 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
208 my ($mxscore, $time, $tries, $totaltime) = @_;
209 my $score = $mxscore;
210 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
211 $score = ($totaltime - $time) / $totaltime * $score;
212 $score -= $tries / 10 * $mxscore;
213 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
219 $ct = contest_entry
$ct;
221 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
222 my $pblist = problem_list
;
223 my %values = query
('problem_values_sth')->map;
225 my (%scores, %tries, %opens);
226 my $opens = query
(opens_sth
=> $ct->{id
});
227 while ($opens->into(my ($problem, $owner, $time))) {
228 $opens{$problem, $owner} = $time;
231 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
233 while (my $job = $jobs->hash) {
234 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
235 my $time = $job->{date
} - $open;
236 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
237 my $value = $values{$job->{problem
}};
238 my $factor = $job->{result
} ?
0 : 1;
239 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
240 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
243 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
247 user_name
=> object_name
(users
=> $user),
248 score
=> sum
(values %{$scores{$user}}),
249 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
253 $st[0]->{rank
} = 1 if @st;
254 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
257 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
262 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
265 while ($jobs->into(my ($id, $owner, $problem, $result))) {
266 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
269 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
271 my @contest_statuses = map {
273 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
274 } $db->select('contests', 'id')->flat;
277 $db->delete('problem_status');
278 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
279 $db->delete('contest_status');
280 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
284 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
285 my $ht = HTTP
::Tiny
->new;
288 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
299 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
303 my $db = Gruntmaster::Data->connect('dbi:Pg:');
305 my $problem = $db->problem('my_problem');
306 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
307 $problem->rerun; # And rerun all jobs for this problem
311 my $contest = $db->contests->create({ # Create a new contest
313 name => 'My Awesome Contest',
317 $db->contest_problems->create({ # Add a problem to the contest
318 contest => 'my_contest',
319 problem => 'my_problem',
322 say 'The contest has not started yet' if $contest->is_pending;
326 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
327 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
331 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
333 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
339 Equivalent to C<< $schema->resultset('Contest') >>
341 =item contest_problems
343 Equivalent to C<< $schema->resultset('ContestProblem') >>
347 Equivalent to C<< $schema->resultset('Job') >>
351 Equivalent to C<< $schema->resultset('Problem') >>
355 Equivalent to C<< $schema->resultset('User') >>
359 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
363 Equivalent to C<< $schema->resultset('Job')->find($id) >>
367 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
371 Equivalent to C<< $schema->resultset('User')->find($id) >>
375 Returns a list of users as an arrayref containing hashrefs.
377 =item user_entry($id)
379 Returns a hashref with information about the user $id.
381 =item problem_list([%args])
383 Returns a list of problems grouped by level. A hashref with levels as keys.
385 Takes the following arguments:
391 Only show problems owned by this user
395 Only show problems in this contest
399 =item problem_entry($id, [$contest, $user])
401 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
403 =item contest_list([%args])
405 Returns a list of contests grouped by state. A hashref with the following keys:
411 An arrayref of hashrefs representing pending contests
415 An arrayref of hashrefs representing running contests
419 An arrayref of hashrefs representing finished contests
423 Takes the following arguments:
429 Only show contests owned by this user.
433 =item contest_entry($id)
435 Returns a hashref with information about the contest $id.
437 =item job_list([%args])
439 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
445 Only show jobs submitted by this user.
449 Only show jobs submitted in this contest.
453 Only show jobs submitted for this problem.
457 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
463 Returns a hashref with information about the job $id.
469 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
471 =head1 COPYRIGHT AND LICENSE
473 Copyright (C) 2014 by Marius Gavrilescu
475 This library is free software; you can redistribute it and/or modify
476 it under the same terms as Perl itself, either Perl version 5.18.1 or,
477 at your option, any later version of Perl 5 you may have available.