1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
7 our @EXPORT = qw
/purge 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/; ## 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 CONTEST_PUBLIC_COLUMNS
=> [qw
/id name description start stop owner/];
19 use constant PROBLEM_PUBLIC_COLUMNS
=> [qw
/id author writer level name owner private timeout olimit value/];
20 use constant USER_PUBLIC_COLUMNS
=> [qw
/id admin name town university country level/];
21 use constant JOBS_PER_PAGE
=> 50;
24 user_list_sth
=> 'SELECT * FROM user_list LIMIT 200',
25 user_entry_sth
=> 'SELECT * FROM user_data WHERE id = ?',
27 problem_status_sth
=> 'SELECT problem,solved FROM problem_status WHERE owner = ?',
28 contest_status_sth
=> 'SELECT contest,score,rank FROM contest_status WHERE owner = ?',
30 contest_list_sth
=> 'SELECT * FROM contest_entry',
31 contest_entry_sth
=> 'SELECT * FROM contest_entry WHERE id = ?',
32 contest_full_sth
=> 'SELECT * FROM contests WHERE id = ?',
33 contest_problems_sth
=> 'SELECT problem FROM contest_problems JOIN problems pb ON problem=pb.id WHERE contest = ? ORDER BY pb.value',
34 contest_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
35 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
37 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
38 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
39 problem_values_sth
=> 'SELECT id,value FROM problems',
41 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
42 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
48 $db = DBIx
::Simple
->new(@_);
49 $db->keep_statements = 100;
55 my ($stat, @extra) = @_;
56 $db->query($statements{$stat} // $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}
77 if (ref $el eq 'ARRAY') {
78 &add_names
($_) for @
$el
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 my $ret = add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes;
114 $params{$_->{level
}} //= [];
115 push @
{$params{$_->{level
}}}, $_
121 my ($id, $contest, $user) = @_;
122 $contest &&= contest_entry
$contest;
123 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
124 my $limits = query
(limits_sth
=> $id)->hashes;
125 $ret->{limits
} = $limits if @
$limits;
128 $ret->{contest_start
} = $contest->{start
};
129 $ret->{contest_stop
} = $contest->{stop
};
136 my $ret = add_names query
('contest_list_sth')->hashes;
140 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
142 push @
{$ret{$state}}, $_;
150 add_names query
(contest_entry_sth
=> $id)->hash;
155 scalar query
(contest_full_sth
=> $id)->hash;
158 sub contest_has_problem
{
159 my ($contest, $problem) = @_;
160 query
('contest_has_problem_sth', $contest, $problem)->flat
167 maybe contest
=> $args{contest
},
168 maybe owner
=> $args{owner
},
169 maybe problem
=> $args{problem
},
170 maybe result
=> $args{result
},
172 $where{private
} = 0 unless $args{private
};
174 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
175 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
176 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
177 my $jobs = $db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
179 log => add_names
$jobs,
180 current_page
=> $args{page
},
183 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
184 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
191 my $ret = add_names query
(job_entry_sth
=> $id)->hash;
192 $ret->{results
} &&= decode_json
$ret->{results
};
198 scalar query
(job_full_sth
=> $id)->hash
203 $db->update('users', {lastjob
=> time});
205 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
209 my ($mxscore, $time, $tries, $totaltime) = @_;
210 my $score = $mxscore;
211 $time = 0 if $time < 0;
212 $time = 300 if $time > $totaltime;
213 $score = ($totaltime - $time) / $totaltime * $score;
214 $score -= $tries / 10 * $mxscore;
215 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
221 $ct = contest_entry
$ct;
223 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
224 my $pblist = problem_list
;
225 my %values = query
('problem_values_sth')->map;
226 # $values{$_} = $values{$_}->{value} for keys %values;
228 my (%scores, %tries, %opens);
229 my $opens = query
(opens_sth
=> $ct->{id
});
230 while ($opens->into(my ($problem, $owner, $time))) {
231 $opens{$problem, $owner} = $time;
234 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
236 while (my $job = $jobs->hash) {
237 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
238 my $time = $job->{date
} - $open;
240 my $value = $values{$job->{problem
}};
241 my $factor = $job->{result
} ?
0 : 1;
242 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
243 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
246 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
250 user_name
=> object_name
(users
=> $user),
251 score
=> sum
(values %{$scores{$user}}),
252 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
256 $st[0]->{rank
} = 1 if @st;
257 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
260 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
265 my $jobs = $db->select('jobs', 'id,owner,problem,result', {}, 'id');
268 while ($jobs->into(my ($id, $owner, $problem, $result))) {
269 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
272 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
274 my @contest_statuses = map {
276 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
277 } $db->select('contests', 'id')->flat;
280 $db->delete('problem_status');
281 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
282 $db->delete('contest_status');
283 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
287 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
288 my $ht = HTTP
::Tiny
->new;
291 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
302 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
306 my $db = Gruntmaster::Data->connect('dbi:Pg:');
308 my $problem = $db->problem('my_problem');
309 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
310 $problem->rerun; # And rerun all jobs for this problem
314 my $contest = $db->contests->create({ # Create a new contest
316 name => 'My Awesome Contest',
320 $db->contest_problems->create({ # Add a problem to the contest
321 contest => 'my_contest',
322 problem => 'my_problem',
325 say 'The contest has not started yet' if $contest->is_pending;
329 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
330 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
334 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
336 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
342 Equivalent to C<< $schema->resultset('Contest') >>
344 =item contest_problems
346 Equivalent to C<< $schema->resultset('ContestProblem') >>
350 Equivalent to C<< $schema->resultset('Job') >>
354 Equivalent to C<< $schema->resultset('Problem') >>
358 Equivalent to C<< $schema->resultset('User') >>
362 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
366 Equivalent to C<< $schema->resultset('Job')->find($id) >>
370 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
374 Equivalent to C<< $schema->resultset('User')->find($id) >>
378 Returns a list of users as an arrayref containing hashrefs.
380 =item user_entry($id)
382 Returns a hashref with information about the user $id.
384 =item problem_list([%args])
386 Returns a list of problems grouped by level. A hashref with levels as keys.
388 Takes the following arguments:
394 Only show problems owned by this user
398 Only show problems in this contest
402 =item problem_entry($id, [$contest, $user])
404 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
406 =item contest_list([%args])
408 Returns a list of contests grouped by state. A hashref with the following keys:
414 An arrayref of hashrefs representing pending contests
418 An arrayref of hashrefs representing running contests
422 An arrayref of hashrefs representing finished contests
426 Takes the following arguments:
432 Only show contests owned by this user.
436 =item contest_entry($id)
438 Returns a hashref with information about the contest $id.
440 =item job_list([%args])
442 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
448 Only show jobs submitted by this user.
452 Only show jobs submitted in this contest.
456 Only show jobs submitted for this problem.
460 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
466 Returns a hashref with information about the job $id.
472 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
474 =head1 COPYRIGHT AND LICENSE
476 Copyright (C) 2014 by Marius Gavrilescu
478 This library is free software; you can redistribute it and/or modify
479 it under the same terms as Perl itself, either Perl version 5.18.1 or,
480 at your option, any later version of Perl 5 you may have available.