1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
7 our @EXPORT = qw
/dbinit purge db user_list user_entry problem_list problem_entry contest_list contest_entry contest_has_problem job_list job_entry 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_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
31 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
33 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
34 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
36 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
38 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
39 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING 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 return unless defined $el;
76 if (ref $el eq 'ARRAY') {
77 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
79 for my $object (qw
/contest owner problem/) {
80 my $table = $object eq 'owner' ?
'users' : "${object}s";
81 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
88 sub user_list
{ scalar query
('user_list_sth')->hashes }
92 my $ret = query
('user_entry_sth', $id)->hash;
93 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
94 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
101 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
102 push @columns, 'solution' if $args{solution
};
104 $where{private
} = 0 unless $args{contest
} || $args{private
};
105 $where{'cp.contest'} = $args{contest
} if $args{contest
};
106 $where{owner
} = $args{owner
} if $args{owner
};
108 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
109 add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes
113 my ($id, $contest) = @_;
114 $contest = contest_entry
($contest) if $contest;
115 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
116 my $limits = query
(limits_sth
=> $id)->hashes;
117 $ret->{limits
} = $limits if @
$limits;
120 $ret->{contest_start
} = $contest->{start
};
121 $ret->{contest_stop
} = $contest->{stop
};
122 delete $ret->{solution
}
128 sub contest_list
{ add_names query
('contest_list_sth')->hashes }
130 sub contest_entry
{ add_names query
(contest_entry_sth
=> $_[0])->hash }
132 sub contest_has_problem
{ query
('contest_has_problem_sth', @_[0, 1])->flat }
136 $args{page
} = int ($args{page
} // 1);
138 maybe contest
=> $args{contest
},
139 maybe owner
=> $args{owner
},
140 maybe problem
=> $args{problem
},
141 maybe result
=> $args{result
},
143 $where{private
} = 0 unless $args{private
};
145 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
146 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
147 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
148 my $jobs = add_names
$db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
150 current_page
=> $args{page
},
152 ($args{page
} - 1) ?
(previous_page
=> $args{page
} - 1) : (),
153 ($args{page
} < $pages) ?
(next_page
=> $args{page
} + 1) : (),
155 wantarray ?
($jobs, $pageinfo) : $jobs;
159 my $ret = add_names query
(job_entry_sth
=> $_[0])->hash;
160 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
166 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
168 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
172 my ($mxscore, $time, $tries, $totaltime) = @_;
173 my $score = $mxscore;
174 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
175 $score = ($totaltime - $time) / $totaltime * $score;
176 $score -= $tries / 10 * $mxscore;
177 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
183 my @problems = sort { $a->{value
} <=> $b->{value
} } @
{problem_list contest
=> $ct};
184 my %values = map { $_->{id
} => $_->{value
} } @problems;
185 $ct = contest_entry
$ct;
187 my (%scores, %tries, %opens);
188 my $opens = query
(opens_sth
=> $ct->{id
});
189 while ($opens->into(my ($problem, $owner, $time))) {
190 $opens{$problem, $owner} = $time;
193 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
195 while (my $job = $jobs->hash) {
196 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
197 my $time = $job->{date
} - $open;
198 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
199 my $value = $values{$job->{problem
}};
200 my $factor = $job->{result
} ?
0 : 1;
201 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
202 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * _calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
205 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
209 user_name
=> object_name
(users
=> $user),
210 score
=> sum
(values %{$scores{$user}}),
211 scores
=> [map { $scores{$user}{$_->{id
}} // '-'} @problems],
215 $st[0]->{rank
} = 1 if @st;
216 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
222 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
225 while ($jobs->into(my ($id, $owner, $problem, $result))) {
226 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
229 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
231 my @contest_statuses = map {
233 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
$ct}
234 } $db->select('contests', 'id')->flat;
237 $db->delete('problem_status');
238 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
239 $db->delete('contest_status');
240 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
246 query rerun_job_sth
=> $id;
253 my $id = query
(take_job_sth
=> $daemon)->list;
254 return $id ? db
->select(jobs
=> '*', {id
=> $id})->hash : undef;
258 my ($job, $private, %args) = @_;
259 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
262 problem
=> $job->{problem
},
263 owner
=> $job->{owner
},
265 solved
=> ($args{result
} ?
0 : 1),
268 db
->insert(problem_status
=> $status)
269 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
272 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
273 my $ht = HTTP
::Tiny
->new;
276 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
287 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
291 my $db = Gruntmaster::Data->connect('dbi:Pg:');
293 my $problem = $db->problem('my_problem');
294 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
295 $problem->rerun; # And rerun all jobs for this problem
299 my $contest = $db->contests->create({ # Create a new contest
301 name => 'My Awesome Contest',
305 $db->contest_problems->create({ # Add a problem to the contest
306 contest => 'my_contest',
307 problem => 'my_problem',
310 say 'The contest has not started yet' if $contest->is_pending;
314 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
315 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
319 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
321 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
327 Equivalent to C<< $schema->resultset('Contest') >>
329 =item contest_problems
331 Equivalent to C<< $schema->resultset('ContestProblem') >>
335 Equivalent to C<< $schema->resultset('Job') >>
339 Equivalent to C<< $schema->resultset('Problem') >>
343 Equivalent to C<< $schema->resultset('User') >>
347 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
351 Equivalent to C<< $schema->resultset('Job')->find($id) >>
355 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
359 Equivalent to C<< $schema->resultset('User')->find($id) >>
363 Returns a list of users as an arrayref containing hashrefs.
365 =item user_entry($id)
367 Returns a hashref with information about the user $id.
369 =item problem_list([%args])
371 Returns a list of problems grouped by level. A hashref with levels as keys.
373 Takes the following arguments:
379 Only show problems owned by this user
383 Only show problems in this contest
387 =item problem_entry($id, [$contest, $user])
389 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
391 =item contest_list([%args])
393 Returns a list of contests grouped by state. A hashref with the following keys:
399 An arrayref of hashrefs representing pending contests
403 An arrayref of hashrefs representing running contests
407 An arrayref of hashrefs representing finished contests
411 Takes the following arguments:
417 Only show contests owned by this user.
421 =item contest_entry($id)
423 Returns a hashref with information about the contest $id.
425 =item job_list([%args])
427 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
433 Only show jobs submitted by this user.
437 Only show jobs submitted in this contest.
441 Only show jobs submitted for this problem.
445 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
451 Returns a hashref with information about the job $id.
457 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
459 =head1 COPYRIGHT AND LICENSE
461 Copyright (C) 2014 by Marius Gavrilescu
463 This library is free software; you can redistribute it and/or modify
464 it under the same terms as Perl itself, either Perl version 5.18.1 or,
465 at your option, any later version of Perl 5 you may have available.