1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
7 our @EXPORT = qw
/purge db 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 rerun_job/; ## 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 = ?',
42 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
49 $db = DBIx
::Simple
->new(@_);
50 $db->keep_statements = 100;
56 my ($stat, @extra) = @_;
57 $db->query($statements{$stat}, @extra)
60 my (%name_cache, %name_cache_time);
61 use constant NAME_CACHE_MAX_AGE
=> 5;
64 my ($table, $id) = @_;
65 $name_cache_time{$table} //= 0;
66 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
67 $name_cache_time{$table} = time;
68 $name_cache{$table} = {};
69 $name_cache{$table} = $db->select($table, 'id,name')->map;
72 $name_cache{$table}{$id}
76 sub add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
78 if (ref $el eq 'ARRAY') {
79 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
81 for my $object (qw
/contest owner problem/) {
82 my $table = $object eq 'owner' ?
'users' : "${object}s";
83 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
90 sub user_list
{ +{us
=> scalar query
('user_list_sth')->hashes} }
94 my $ret = query
('user_entry_sth', $id)->hash;
95 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
96 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
103 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
104 push @columns, 'solution' if $args{solution
};
106 $where{private
} = 0 unless $args{contest
} || $args{private
};
107 $where{'cp.contest'} = $args{contest
} if $args{contest
};
108 $where{owner
} = $args{owner
} if $args{owner
};
110 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
111 my $ret = add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes;
115 $params{$_->{level
}} //= [];
116 push @
{$params{$_->{level
}}}, $_
122 my ($id, $contest) = @_;
123 $contest = contest_entry
($contest) if $contest;
124 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
125 my $limits = query
(limits_sth
=> $id)->hashes;
126 $ret->{limits
} = $limits if @
$limits;
129 $ret->{contest_start
} = $contest->{start
};
130 $ret->{contest_stop
} = $contest->{stop
};
131 delete $ret->{solution
}
138 my $ret = add_names query
('contest_list_sth')->hashes;
142 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
144 push @
{$ret{$state}}, $_;
152 add_names query
(contest_entry_sth
=> $id)->hash;
157 scalar query
(contest_full_sth
=> $id)->hash;
160 sub contest_has_problem
{
161 my ($contest, $problem) = @_;
162 query
('contest_has_problem_sth', $contest, $problem)->flat
169 maybe contest
=> $args{contest
},
170 maybe owner
=> $args{owner
},
171 maybe problem
=> $args{problem
},
172 maybe result
=> $args{result
},
174 $where{private
} = 0 unless $args{private
};
176 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
177 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
178 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
179 my $jobs = $db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
181 log => add_names
$jobs,
182 current_page
=> $args{page
},
185 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
186 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
193 my $ret = add_names query
(job_entry_sth
=> $id)->hash;
194 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
200 scalar query
(job_full_sth
=> $id)->hash
205 $db->update('users', {lastjob
=> time});
207 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
211 my ($mxscore, $time, $tries, $totaltime) = @_;
212 my $score = $mxscore;
213 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
214 $score = ($totaltime - $time) / $totaltime * $score;
215 $score -= $tries / 10 * $mxscore;
216 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
222 $ct = contest_entry
$ct;
224 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
225 my $pblist = problem_list
;
226 my %values = query
('problem_values_sth')->map;
228 my (%scores, %tries, %opens);
229 my $opens = query
(opens_sth
=> $ct->{id
});
230 while ($opens->into(my ($problem, $owner, $time))) {
231 $opens{$problem, $owner} = $time;
234 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
236 while (my $job = $jobs->hash) {
237 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
238 my $time = $job->{date
} - $open;
239 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
240 my $value = $values{$job->{problem
}};
241 my $factor = $job->{result
} ?
0 : 1;
242 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
243 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
246 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
250 user_name
=> object_name
(users
=> $user),
251 score
=> sum
(values %{$scores{$user}}),
252 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
256 $st[0]->{rank
} = 1 if @st;
257 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
260 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
265 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
268 while ($jobs->into(my ($id, $owner, $problem, $result))) {
269 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
272 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
274 my @contest_statuses = map {
276 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
277 } $db->select('contests', 'id')->flat;
280 $db->delete('problem_status');
281 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
282 $db->delete('contest_status');
283 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
289 $db->query(rerun_job_sth
=> $id);
294 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
295 my $ht = HTTP
::Tiny
->new;
298 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
309 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
313 my $db = Gruntmaster::Data->connect('dbi:Pg:');
315 my $problem = $db->problem('my_problem');
316 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
317 $problem->rerun; # And rerun all jobs for this problem
321 my $contest = $db->contests->create({ # Create a new contest
323 name => 'My Awesome Contest',
327 $db->contest_problems->create({ # Add a problem to the contest
328 contest => 'my_contest',
329 problem => 'my_problem',
332 say 'The contest has not started yet' if $contest->is_pending;
336 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
337 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
341 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
343 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
349 Equivalent to C<< $schema->resultset('Contest') >>
351 =item contest_problems
353 Equivalent to C<< $schema->resultset('ContestProblem') >>
357 Equivalent to C<< $schema->resultset('Job') >>
361 Equivalent to C<< $schema->resultset('Problem') >>
365 Equivalent to C<< $schema->resultset('User') >>
369 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
373 Equivalent to C<< $schema->resultset('Job')->find($id) >>
377 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
381 Equivalent to C<< $schema->resultset('User')->find($id) >>
385 Returns a list of users as an arrayref containing hashrefs.
387 =item user_entry($id)
389 Returns a hashref with information about the user $id.
391 =item problem_list([%args])
393 Returns a list of problems grouped by level. A hashref with levels as keys.
395 Takes the following arguments:
401 Only show problems owned by this user
405 Only show problems in this contest
409 =item problem_entry($id, [$contest, $user])
411 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
413 =item contest_list([%args])
415 Returns a list of contests grouped by state. A hashref with the following keys:
421 An arrayref of hashrefs representing pending contests
425 An arrayref of hashrefs representing running contests
429 An arrayref of hashrefs representing finished contests
433 Takes the following arguments:
439 Only show contests owned by this user.
443 =item contest_entry($id)
445 Returns a hashref with information about the contest $id.
447 =item job_list([%args])
449 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
455 Only show jobs submitted by this user.
459 Only show jobs submitted in this contest.
463 Only show jobs submitted for this problem.
467 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
473 Returns a hashref with information about the job $id.
479 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
481 =head1 COPYRIGHT AND LICENSE
483 Copyright (C) 2014 by Marius Gavrilescu
485 This library is free software; you can redistribute it and/or modify
486 it under the same terms as Perl itself, either Perl version 5.18.1 or,
487 at your option, any later version of Perl 5 you may have available.