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)
8 our @EXPORT_OK = @EXPORT;
10 use JSON
::MaybeXS qw
/decode_json/;
12 use PerlX
::Maybe qw
/maybe/;
16 use List
::Util qw
/sum/;
19 use constant PROBLEM_PUBLIC_COLUMNS
=> [qw
/id author writer level name owner private timeout olimit value/];
20 use constant JOBS_PER_PAGE
=> 50;
23 user_list_sth
=> 'SELECT * FROM user_list LIMIT 200',
24 user_entry_sth
=> 'SELECT * FROM user_data WHERE id = ?',
26 problem_status_sth
=> 'SELECT problem,solved FROM problem_status WHERE owner = ?',
27 contest_status_sth
=> 'SELECT contest,score,rank FROM contest_status WHERE owner = ?',
29 contest_list_sth
=> 'SELECT * FROM contest_entry',
30 contest_entry_sth
=> 'SELECT * FROM contest_entry WHERE id = ?',
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 = ?',
37 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
39 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
40 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING id',
47 $db = DBIx
::Simple
->new(@_);
48 $db->keep_statements = 100;
54 my ($stat, @extra) = @_;
55 $db->query($statements{$stat}, @extra)
58 my (%name_cache, %name_cache_time);
59 use constant NAME_CACHE_MAX_AGE
=> 5;
62 my ($table, $id) = @_;
63 $name_cache_time{$table} //= 0;
64 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
65 $name_cache_time{$table} = time;
66 $name_cache{$table} = {};
67 $name_cache{$table} = $db->select($table, 'id,name')->map;
70 $name_cache{$table}{$id}
74 sub _add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
76 return unless defined $el;
77 if (ref $el eq 'ARRAY') {
78 &_add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
80 for my $object (qw
/contest owner problem/) {
81 my $table = $object eq 'owner' ?
'users' : "${object}s";
82 $el->{"${object}_name"} = _object_name
$table, $el->{$object} if defined $el->{$object}
89 sub user_list
{ scalar _query
('user_list_sth')->hashes }
93 my $ret = _query
('user_entry_sth', $id)->hash;
94 $ret->{problems
} = _add_names _query
('problem_status_sth', $id)->hashes;
95 $ret->{contests
} = _add_names _query
('contest_status_sth', $id)->hashes;
102 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
103 push @columns, 'solution' if $args{solution
};
105 $where{private
} = 0 unless $args{contest
} || $args{private
};
106 $where{'cp.contest'} = $args{contest
} if $args{contest
};
107 $where{owner
} = $args{owner
} if $args{owner
};
109 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
110 _add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes
114 my ($id, $contest) = @_;
115 $contest = contest_entry
($contest) if $contest;
116 my $ret = _add_names _query
(problem_entry_sth
=> $id)->hash;
117 my $limits = _query
(limits_sth
=> $id)->hashes;
118 $ret->{limits
} = $limits if @
$limits;
121 $ret->{contest_start
} = $contest->{start
};
122 $ret->{contest_stop
} = $contest->{stop
};
123 delete $ret->{solution
}
129 sub contest_list
{ _add_names _query
('contest_list_sth')->hashes }
131 sub contest_entry
{ _add_names _query
(contest_entry_sth
=> $_[0])->hash }
133 sub contest_has_problem
{ _query
('contest_has_problem_sth', @_[0, 1])->flat }
137 $args{page
} = int ($args{page
} // 1);
139 maybe contest
=> $args{contest
},
140 maybe owner
=> $args{owner
},
141 maybe problem
=> $args{problem
},
142 maybe result
=> $args{result
},
144 $where{private
} = 0 unless $args{private
};
146 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
147 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
148 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
149 my $jobs = _add_names
$db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
151 current_page
=> $args{page
},
153 ($args{page
} - 1) ?
(previous_page
=> $args{page
} - 1) : (),
154 ($args{page
} < $pages) ?
(next_page
=> $args{page
} + 1) : (),
156 wantarray ?
($jobs, $pageinfo) : $jobs;
160 my $ret = _add_names _query
(job_entry_sth
=> $_[0])->hash;
161 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
167 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
169 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
173 my ($mxscore, $time, $tries, $totaltime) = @_;
174 my $score = $mxscore;
175 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
176 $score = ($totaltime - $time) / $totaltime * $score;
177 $score -= $tries / 10 * $mxscore;
178 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
184 my @problems = sort { $a->{value
} <=> $b->{value
} } @
{problem_list contest
=> $ct};
185 my %values = map { $_->{id
} => $_->{value
} } @problems;
186 $ct = contest_entry
$ct;
188 my (%scores, %tries, %opens);
189 my $opens = _query
(opens_sth
=> $ct->{id
});
190 while ($opens->into(my ($problem, $owner, $time))) {
191 $opens{$problem, $owner} = $time;
194 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
196 while (my $job = $jobs->hash) {
197 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
198 my $time = $job->{date
} - $open;
199 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
200 my $value = $values{$job->{problem
}};
201 my $factor = $job->{result
} ?
0 : 1;
202 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
203 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * _calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
206 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
210 user_name
=> _object_name
(users
=> $user),
211 score
=> sum
(values %{$scores{$user}}),
212 scores
=> [map { $scores{$user}{$_->{id
}} // '-'} @problems],
216 $st[0]->{rank
} = 1 if @st;
217 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
223 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
226 while ($jobs->into(my ($id, $owner, $problem, $result))) {
227 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
230 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
232 my @contest_statuses = map {
234 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
$ct}
235 } $db->select('contests', 'id')->flat;
238 $db->delete('problem_status');
239 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
240 $db->delete('contest_status');
241 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
247 _query rerun_job_sth
=> $id;
254 my $id = _query
(take_job_sth
=> $daemon)->list;
255 return $id ? db
->select(jobs
=> '*', {id
=> $id})->hash : undef;
259 my ($job, $private, %args) = @_;
260 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
263 problem
=> $job->{problem
},
264 owner
=> $job->{owner
},
266 solved
=> ($args{result
} ?
0 : 1),
269 db
->insert(problem_status
=> $status)
270 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
273 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
274 my $ht = HTTP
::Tiny
->new;
277 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
288 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
292 my $db = Gruntmaster::Data->connect('dbi:Pg:');
294 my $problem = $db->problem('my_problem');
295 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
296 $problem->rerun; # And rerun all jobs for this problem
300 my $contest = $db->contests->create({ # Create a new contest
302 name => 'My Awesome Contest',
306 $db->contest_problems->create({ # Add a problem to the contest
307 contest => 'my_contest',
308 problem => 'my_problem',
311 say 'The contest has not started yet' if $contest->is_pending;
315 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
316 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
320 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
322 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
328 Equivalent to C<< $schema->resultset('Contest') >>
330 =item contest_problems
332 Equivalent to C<< $schema->resultset('ContestProblem') >>
336 Equivalent to C<< $schema->resultset('Job') >>
340 Equivalent to C<< $schema->resultset('Problem') >>
344 Equivalent to C<< $schema->resultset('User') >>
348 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
352 Equivalent to C<< $schema->resultset('Job')->find($id) >>
356 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
360 Equivalent to C<< $schema->resultset('User')->find($id) >>
364 Returns a list of users as an arrayref containing hashrefs.
366 =item user_entry($id)
368 Returns a hashref with information about the user $id.
370 =item problem_list([%args])
372 Returns a list of problems grouped by level. A hashref with levels as keys.
374 Takes the following arguments:
380 Only show problems owned by this user
384 Only show problems in this contest
388 =item problem_entry($id, [$contest, $user])
390 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
392 =item contest_list([%args])
394 Returns a list of contests grouped by state. A hashref with the following keys:
400 An arrayref of hashrefs representing pending contests
404 An arrayref of hashrefs representing running contests
408 An arrayref of hashrefs representing finished contests
412 Takes the following arguments:
418 Only show contests owned by this user.
422 =item contest_entry($id)
424 Returns a hashref with information about the contest $id.
426 =item job_list([%args])
428 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
434 Only show jobs submitted by this user.
438 Only show jobs submitted in this contest.
442 Only show jobs submitted for this problem.
446 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
452 Returns a hashref with information about the job $id.
458 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
460 =head1 COPYRIGHT AND LICENSE
462 Copyright (C) 2014 by Marius Gavrilescu
464 This library is free software; you can redistribute it and/or modify
465 it under the same terms as Perl itself, either Perl version 5.18.1 or,
466 at your option, any later version of Perl 5 you may have available.