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 return unless defined $el;
79 if (ref $el eq 'ARRAY') {
80 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
82 for my $object (qw
/contest owner problem/) {
83 my $table = $object eq 'owner' ?
'users' : "${object}s";
84 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
91 sub user_list
{ +{us
=> scalar query
('user_list_sth')->hashes} }
95 my $ret = query
('user_entry_sth', $id)->hash;
96 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
97 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
104 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
105 push @columns, 'solution' if $args{solution
};
107 $where{private
} = 0 unless $args{contest
} || $args{private
};
108 $where{'cp.contest'} = $args{contest
} if $args{contest
};
109 $where{owner
} = $args{owner
} if $args{owner
};
111 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
112 my $ret = add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes;
116 $params{$_->{level
}} //= [];
117 push @
{$params{$_->{level
}}}, $_
123 my ($id, $contest) = @_;
124 $contest = contest_entry
($contest) if $contest;
125 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
126 my $limits = query
(limits_sth
=> $id)->hashes;
127 $ret->{limits
} = $limits if @
$limits;
130 $ret->{contest_start
} = $contest->{start
};
131 $ret->{contest_stop
} = $contest->{stop
};
132 delete $ret->{solution
}
139 my $ret = add_names query
('contest_list_sth')->hashes;
143 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
145 push @
{$ret{$state}}, $_;
153 add_names query
(contest_entry_sth
=> $id)->hash;
158 scalar query
(contest_full_sth
=> $id)->hash;
161 sub contest_has_problem
{
162 my ($contest, $problem) = @_;
163 query
('contest_has_problem_sth', $contest, $problem)->flat
170 maybe contest
=> $args{contest
},
171 maybe owner
=> $args{owner
},
172 maybe problem
=> $args{problem
},
173 maybe result
=> $args{result
},
175 $where{private
} = 0 unless $args{private
};
177 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
178 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
179 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
180 my $jobs = $db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
182 log => add_names
$jobs,
183 current_page
=> $args{page
},
186 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
187 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
194 my $ret = add_names query
(job_entry_sth
=> $id)->hash;
195 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
201 scalar query
(job_full_sth
=> $id)->hash
206 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
208 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
212 my ($mxscore, $time, $tries, $totaltime) = @_;
213 my $score = $mxscore;
214 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
215 $score = ($totaltime - $time) / $totaltime * $score;
216 $score -= $tries / 10 * $mxscore;
217 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
223 $ct = contest_entry
$ct;
225 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
226 my $pblist = problem_list
;
227 my %values = query
('problem_values_sth')->map;
229 my (%scores, %tries, %opens);
230 my $opens = query
(opens_sth
=> $ct->{id
});
231 while ($opens->into(my ($problem, $owner, $time))) {
232 $opens{$problem, $owner} = $time;
235 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
237 while (my $job = $jobs->hash) {
238 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
239 my $time = $job->{date
} - $open;
240 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
241 my $value = $values{$job->{problem
}};
242 my $factor = $job->{result
} ?
0 : 1;
243 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
244 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
247 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
251 user_name
=> object_name
(users
=> $user),
252 score
=> sum
(values %{$scores{$user}}),
253 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
257 $st[0]->{rank
} = 1 if @st;
258 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
261 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
266 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
269 while ($jobs->into(my ($id, $owner, $problem, $result))) {
270 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
273 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
275 my @contest_statuses = map {
277 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
278 } $db->select('contests', 'id')->flat;
281 $db->delete('problem_status');
282 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
283 $db->delete('contest_status');
284 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
290 $db->query(rerun_job_sth
=> $id);
295 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
296 my $ht = HTTP
::Tiny
->new;
299 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
310 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
314 my $db = Gruntmaster::Data->connect('dbi:Pg:');
316 my $problem = $db->problem('my_problem');
317 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
318 $problem->rerun; # And rerun all jobs for this problem
322 my $contest = $db->contests->create({ # Create a new contest
324 name => 'My Awesome Contest',
328 $db->contest_problems->create({ # Add a problem to the contest
329 contest => 'my_contest',
330 problem => 'my_problem',
333 say 'The contest has not started yet' if $contest->is_pending;
337 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
338 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
342 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
344 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
350 Equivalent to C<< $schema->resultset('Contest') >>
352 =item contest_problems
354 Equivalent to C<< $schema->resultset('ContestProblem') >>
358 Equivalent to C<< $schema->resultset('Job') >>
362 Equivalent to C<< $schema->resultset('Problem') >>
366 Equivalent to C<< $schema->resultset('User') >>
370 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
374 Equivalent to C<< $schema->resultset('Job')->find($id) >>
378 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
382 Equivalent to C<< $schema->resultset('User')->find($id) >>
386 Returns a list of users as an arrayref containing hashrefs.
388 =item user_entry($id)
390 Returns a hashref with information about the user $id.
392 =item problem_list([%args])
394 Returns a list of problems grouped by level. A hashref with levels as keys.
396 Takes the following arguments:
402 Only show problems owned by this user
406 Only show problems in this contest
410 =item problem_entry($id, [$contest, $user])
412 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
414 =item contest_list([%args])
416 Returns a list of contests grouped by state. A hashref with the following keys:
422 An arrayref of hashrefs representing pending contests
426 An arrayref of hashrefs representing running contests
430 An arrayref of hashrefs representing finished contests
434 Takes the following arguments:
440 Only show contests owned by this user.
444 =item contest_entry($id)
446 Returns a hashref with information about the contest $id.
448 =item job_list([%args])
450 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
456 Only show jobs submitted by this user.
460 Only show jobs submitted in this contest.
464 Only show jobs submitted for this problem.
468 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
474 Returns a hashref with information about the job $id.
480 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
482 =head1 COPYRIGHT AND LICENSE
484 Copyright (C) 2014 by Marius Gavrilescu
486 This library is free software; you can redistribute it and/or modify
487 it under the same terms as Perl itself, either Perl version 5.18.1 or,
488 at your option, any later version of Perl 5 you may have available.