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 problem_full contest_list contest_entry contest_full contest_has_problem job_list job_entry job_full create_job standings update_status rerun_job take_job finish_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 problem_full_sth
=> 'SELECT * FROM problems WHERE id = ?',
37 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
38 problem_values_sth
=> 'SELECT id,value FROM problems',
40 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
41 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
43 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
44 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING id',
51 $db = DBIx
::Simple
->new(@_);
52 $db->keep_statements = 100;
58 my ($stat, @extra) = @_;
59 $db->query($statements{$stat}, @extra)
62 my (%name_cache, %name_cache_time);
63 use constant NAME_CACHE_MAX_AGE
=> 5;
66 my ($table, $id) = @_;
67 $name_cache_time{$table} //= 0;
68 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
69 $name_cache_time{$table} = time;
70 $name_cache{$table} = {};
71 $name_cache{$table} = $db->select($table, 'id,name')->map;
74 $name_cache{$table}{$id}
78 sub add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
80 return unless defined $el;
81 if (ref $el eq 'ARRAY') {
82 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
84 for my $object (qw
/contest owner problem/) {
85 my $table = $object eq 'owner' ?
'users' : "${object}s";
86 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
93 sub user_list
{ +{us
=> scalar query
('user_list_sth')->hashes} }
97 my $ret = query
('user_entry_sth', $id)->hash;
98 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
99 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
106 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
107 push @columns, 'solution' if $args{solution
};
109 $where{private
} = 0 unless $args{contest
} || $args{private
};
110 $where{'cp.contest'} = $args{contest
} if $args{contest
};
111 $where{owner
} = $args{owner
} if $args{owner
};
113 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
114 my $ret = add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes;
118 $params{$_->{level
}} //= [];
119 push @
{$params{$_->{level
}}}, $_
125 my ($id, $contest) = @_;
126 $contest = contest_entry
($contest) if $contest;
127 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
128 my $limits = query
(limits_sth
=> $id)->hashes;
129 $ret->{limits
} = $limits if @
$limits;
132 $ret->{contest_start
} = $contest->{start
};
133 $ret->{contest_stop
} = $contest->{stop
};
134 delete $ret->{solution
}
142 scalar query
(problem_full_sth
=> $id)->hash;
146 my $ret = add_names query
('contest_list_sth')->hashes;
150 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
152 push @
{$ret{$state}}, $_;
160 add_names query
(contest_entry_sth
=> $id)->hash;
165 scalar query
(contest_full_sth
=> $id)->hash;
168 sub contest_has_problem
{
169 my ($contest, $problem) = @_;
170 query
('contest_has_problem_sth', $contest, $problem)->flat
177 maybe contest
=> $args{contest
},
178 maybe owner
=> $args{owner
},
179 maybe problem
=> $args{problem
},
180 maybe result
=> $args{result
},
182 $where{private
} = 0 unless $args{private
};
184 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
185 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
186 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
187 my $jobs = $db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
189 log => add_names
$jobs,
190 current_page
=> $args{page
},
193 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
194 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
201 my $ret = add_names query
(job_entry_sth
=> $id)->hash;
202 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
208 scalar query
(job_full_sth
=> $id)->hash
213 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
215 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
219 my ($mxscore, $time, $tries, $totaltime) = @_;
220 my $score = $mxscore;
221 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
222 $score = ($totaltime - $time) / $totaltime * $score;
223 $score -= $tries / 10 * $mxscore;
224 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
230 $ct = contest_entry
$ct;
232 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
233 my $pblist = problem_list
;
234 my %values = query
('problem_values_sth')->map;
236 my (%scores, %tries, %opens);
237 my $opens = query
(opens_sth
=> $ct->{id
});
238 while ($opens->into(my ($problem, $owner, $time))) {
239 $opens{$problem, $owner} = $time;
242 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
244 while (my $job = $jobs->hash) {
245 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
246 my $time = $job->{date
} - $open;
247 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
248 my $value = $values{$job->{problem
}};
249 my $factor = $job->{result
} ?
0 : 1;
250 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
251 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
254 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
258 user_name
=> object_name
(users
=> $user),
259 score
=> sum
(values %{$scores{$user}}),
260 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
264 $st[0]->{rank
} = 1 if @st;
265 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
268 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
273 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
276 while ($jobs->into(my ($id, $owner, $problem, $result))) {
277 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
280 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
282 my @contest_statuses = map {
284 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
285 } $db->select('contests', 'id')->flat;
288 $db->delete('problem_status');
289 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
290 $db->delete('contest_status');
291 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
297 query rerun_job_sth
=> $id;
304 my $id = query
(take_job_sth
=> $daemon)->list;
305 return $id ? job_full
$id : undef;
309 my ($job, $private, %args) = @_;
310 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
313 problem
=> $job->{problem
},
314 owner
=> $job->{owner
},
316 solved
=> ($args{result
} ?
0 : 1),
319 db
->insert(problem_status
=> $status)
320 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
323 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
324 my $ht = HTTP
::Tiny
->new;
327 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
338 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
342 my $db = Gruntmaster::Data->connect('dbi:Pg:');
344 my $problem = $db->problem('my_problem');
345 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
346 $problem->rerun; # And rerun all jobs for this problem
350 my $contest = $db->contests->create({ # Create a new contest
352 name => 'My Awesome Contest',
356 $db->contest_problems->create({ # Add a problem to the contest
357 contest => 'my_contest',
358 problem => 'my_problem',
361 say 'The contest has not started yet' if $contest->is_pending;
365 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
366 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
370 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
372 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
378 Equivalent to C<< $schema->resultset('Contest') >>
380 =item contest_problems
382 Equivalent to C<< $schema->resultset('ContestProblem') >>
386 Equivalent to C<< $schema->resultset('Job') >>
390 Equivalent to C<< $schema->resultset('Problem') >>
394 Equivalent to C<< $schema->resultset('User') >>
398 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
402 Equivalent to C<< $schema->resultset('Job')->find($id) >>
406 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
410 Equivalent to C<< $schema->resultset('User')->find($id) >>
414 Returns a list of users as an arrayref containing hashrefs.
416 =item user_entry($id)
418 Returns a hashref with information about the user $id.
420 =item problem_list([%args])
422 Returns a list of problems grouped by level. A hashref with levels as keys.
424 Takes the following arguments:
430 Only show problems owned by this user
434 Only show problems in this contest
438 =item problem_entry($id, [$contest, $user])
440 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
442 =item contest_list([%args])
444 Returns a list of contests grouped by state. A hashref with the following keys:
450 An arrayref of hashrefs representing pending contests
454 An arrayref of hashrefs representing running contests
458 An arrayref of hashrefs representing finished contests
462 Takes the following arguments:
468 Only show contests owned by this user.
472 =item contest_entry($id)
474 Returns a hashref with information about the contest $id.
476 =item job_list([%args])
478 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
484 Only show jobs submitted by this user.
488 Only show jobs submitted in this contest.
492 Only show jobs submitted for this problem.
496 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
502 Returns a hashref with information about the job $id.
508 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
510 =head1 COPYRIGHT AND LICENSE
512 Copyright (C) 2014 by Marius Gavrilescu
514 This library is free software; you can redistribute it and/or modify
515 it under the same terms as Perl itself, either Perl version 5.18.1 or,
516 at your option, any later version of Perl 5 you may have available.