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_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_problems_sth
=> 'SELECT problem FROM contest_problems JOIN problems pb ON problem=pb.id WHERE contest = ? ORDER BY pb.value',
31 contest_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
32 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
34 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
35 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
36 problem_values_sth
=> 'SELECT id,value FROM problems',
38 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
40 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
41 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING id',
48 $db = DBIx
::Simple
->new(@_);
49 $db->keep_statements = 100;
55 my ($stat, @extra) = @_;
56 $db->query($statements{$stat}, @extra)
59 my (%name_cache, %name_cache_time);
60 use constant NAME_CACHE_MAX_AGE
=> 5;
63 my ($table, $id) = @_;
64 $name_cache_time{$table} //= 0;
65 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
66 $name_cache_time{$table} = time;
67 $name_cache{$table} = {};
68 $name_cache{$table} = $db->select($table, 'id,name')->map;
71 $name_cache{$table}{$id}
75 sub add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
77 return unless defined $el;
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
{ 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 add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes
115 my ($id, $contest) = @_;
116 $contest = contest_entry
($contest) if $contest;
117 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
118 my $limits = query
(limits_sth
=> $id)->hashes;
119 $ret->{limits
} = $limits if @
$limits;
122 $ret->{contest_start
} = $contest->{start
};
123 $ret->{contest_stop
} = $contest->{stop
};
124 delete $ret->{solution
}
130 sub contest_list
{ add_names query
('contest_list_sth')->hashes }
132 sub contest_entry
{ add_names query
(contest_entry_sth
=> $_[0])->hash }
134 sub contest_has_problem
{ query
('contest_has_problem_sth', @_[0, 1])->flat }
138 $args{page
} = int ($args{page
} // 1);
140 maybe contest
=> $args{contest
},
141 maybe owner
=> $args{owner
},
142 maybe problem
=> $args{problem
},
143 maybe result
=> $args{result
},
145 $where{private
} = 0 unless $args{private
};
147 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
148 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
149 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
150 my $jobs = add_names
$db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
152 current_page
=> $args{page
},
154 ($args{page
} - 1) ?
(previous_page
=> $args{page
} - 1) : (),
155 ($args{page
} < $pages) ?
(next_page
=> $args{page
} + 1) : (),
157 wantarray ?
($jobs, $pageinfo) : $jobs;
161 my $ret = add_names query
(job_entry_sth
=> $_[0])->hash;
162 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
168 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
170 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
174 my ($mxscore, $time, $tries, $totaltime) = @_;
175 my $score = $mxscore;
176 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
177 $score = ($totaltime - $time) / $totaltime * $score;
178 $score -= $tries / 10 * $mxscore;
179 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
185 $ct = contest_entry
$ct;
187 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
188 my $pblist = problem_list
;
189 my %values = query
('problem_values_sth')->map;
191 my (%scores, %tries, %opens);
192 my $opens = query
(opens_sth
=> $ct->{id
});
193 while ($opens->into(my ($problem, $owner, $time))) {
194 $opens{$problem, $owner} = $time;
197 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
199 while (my $job = $jobs->hash) {
200 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
201 my $time = $job->{date
} - $open;
202 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
203 my $value = $values{$job->{problem
}};
204 my $factor = $job->{result
} ?
0 : 1;
205 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
206 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
209 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
213 user_name
=> object_name
(users
=> $user),
214 score
=> sum
(values %{$scores{$user}}),
215 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
219 $st[0]->{rank
} = 1 if @st;
220 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
223 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
228 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
231 while ($jobs->into(my ($id, $owner, $problem, $result))) {
232 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
235 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
237 my @contest_statuses = map {
239 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
240 } $db->select('contests', 'id')->flat;
243 $db->delete('problem_status');
244 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
245 $db->delete('contest_status');
246 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
252 query rerun_job_sth
=> $id;
259 my $id = query
(take_job_sth
=> $daemon)->list;
260 return $id ? db
->select(jobs
=> '*', {id
=> $id})->hash : undef;
264 my ($job, $private, %args) = @_;
265 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
268 problem
=> $job->{problem
},
269 owner
=> $job->{owner
},
271 solved
=> ($args{result
} ?
0 : 1),
274 db
->insert(problem_status
=> $status)
275 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
278 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
279 my $ht = HTTP
::Tiny
->new;
282 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
293 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
297 my $db = Gruntmaster::Data->connect('dbi:Pg:');
299 my $problem = $db->problem('my_problem');
300 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
301 $problem->rerun; # And rerun all jobs for this problem
305 my $contest = $db->contests->create({ # Create a new contest
307 name => 'My Awesome Contest',
311 $db->contest_problems->create({ # Add a problem to the contest
312 contest => 'my_contest',
313 problem => 'my_problem',
316 say 'The contest has not started yet' if $contest->is_pending;
320 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
321 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
325 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
327 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
333 Equivalent to C<< $schema->resultset('Contest') >>
335 =item contest_problems
337 Equivalent to C<< $schema->resultset('ContestProblem') >>
341 Equivalent to C<< $schema->resultset('Job') >>
345 Equivalent to C<< $schema->resultset('Problem') >>
349 Equivalent to C<< $schema->resultset('User') >>
353 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
357 Equivalent to C<< $schema->resultset('Job')->find($id) >>
361 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
365 Equivalent to C<< $schema->resultset('User')->find($id) >>
369 Returns a list of users as an arrayref containing hashrefs.
371 =item user_entry($id)
373 Returns a hashref with information about the user $id.
375 =item problem_list([%args])
377 Returns a list of problems grouped by level. A hashref with levels as keys.
379 Takes the following arguments:
385 Only show problems owned by this user
389 Only show problems in this contest
393 =item problem_entry($id, [$contest, $user])
395 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
397 =item contest_list([%args])
399 Returns a list of contests grouped by state. A hashref with the following keys:
405 An arrayref of hashrefs representing pending contests
409 An arrayref of hashrefs representing running contests
413 An arrayref of hashrefs representing finished contests
417 Takes the following arguments:
423 Only show contests owned by this user.
427 =item contest_entry($id)
429 Returns a hashref with information about the contest $id.
431 =item job_list([%args])
433 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
439 Only show jobs submitted by this user.
443 Only show jobs submitted in this contest.
447 Only show jobs submitted for this problem.
451 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
457 Returns a hashref with information about the job $id.
463 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
465 =head1 COPYRIGHT AND LICENSE
467 Copyright (C) 2014 by Marius Gavrilescu
469 This library is free software; you can redistribute it and/or modify
470 it under the same terms as Perl itself, either Perl version 5.18.1 or,
471 at your option, any later version of Perl 5 you may have available.