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 problem_full contest_list contest_entry contest_full contest_has_problem job_list job_entry job_full 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_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 problem_full_sth
=> 'SELECT * FROM problems WHERE id = ?',
37 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
38 problem_values_sth
=> 'SELECT id,value FROM problems',
40 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
41 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
43 rerun_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
44 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING id',
51 $db = DBIx
::Simple
->new(@_);
52 $db->keep_statements = 100;
58 my ($stat, @extra) = @_;
59 $db->query($statements{$stat}, @extra)
62 my (%name_cache, %name_cache_time);
63 use constant NAME_CACHE_MAX_AGE
=> 5;
66 my ($table, $id) = @_;
67 $name_cache_time{$table} //= 0;
68 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
69 $name_cache_time{$table} = time;
70 $name_cache{$table} = {};
71 $name_cache{$table} = $db->select($table, 'id,name')->map;
74 $name_cache{$table}{$id}
78 sub add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
80 return unless defined $el;
81 if (ref $el eq 'ARRAY') {
82 &add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
84 for my $object (qw
/contest owner problem/) {
85 my $table = $object eq 'owner' ?
'users' : "${object}s";
86 $el->{"${object}_name"} = object_name
$table, $el->{$object} if defined $el->{$object}
93 sub user_list
{ scalar query
('user_list_sth')->hashes }
97 my $ret = query
('user_entry_sth', $id)->hash;
98 $ret->{problems
} = add_names query
('problem_status_sth', $id)->hashes;
99 $ret->{contests
} = add_names query
('contest_status_sth', $id)->hashes;
106 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
107 push @columns, 'solution' if $args{solution
};
109 $where{private
} = 0 unless $args{contest
} || $args{private
};
110 $where{'cp.contest'} = $args{contest
} if $args{contest
};
111 $where{owner
} = $args{owner
} if $args{owner
};
113 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
114 add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes
118 my ($id, $contest) = @_;
119 $contest = contest_entry
($contest) if $contest;
120 my $ret = add_names query
(problem_entry_sth
=> $id)->hash;
121 my $limits = query
(limits_sth
=> $id)->hashes;
122 $ret->{limits
} = $limits if @
$limits;
125 $ret->{contest_start
} = $contest->{start
};
126 $ret->{contest_stop
} = $contest->{stop
};
127 delete $ret->{solution
}
133 sub problem_full
{ scalar query
(problem_full_sth
=> $_[0])->hash }
135 sub contest_list
{ add_names query
('contest_list_sth')->hashes }
137 sub contest_entry
{ add_names query
(contest_entry_sth
=> $_[0])->hash }
139 sub contest_full
{ scalar query
(contest_full_sth
=> $_[0])->hash }
141 sub contest_has_problem
{ query
('contest_has_problem_sth', @_[0, 1])->flat }
145 $args{page
} = int ($args{page
} // 1);
147 maybe contest
=> $args{contest
},
148 maybe owner
=> $args{owner
},
149 maybe problem
=> $args{problem
},
150 maybe result
=> $args{result
},
152 $where{private
} = 0 unless $args{private
};
154 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
155 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
156 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
157 my $jobs = add_names
$db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
159 current_page
=> $args{page
},
161 ($args{page
} - 1) ?
(previous_page
=> $args{page
} - 1) : (),
162 ($args{page
} < $pages) ?
(next_page
=> $args{page
} + 1) : (),
164 wantarray ?
($jobs, $pageinfo) : $jobs;
168 my $ret = add_names query
(job_entry_sth
=> $_[0])->hash;
169 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
173 sub job_full
{ scalar query
(job_full_sth
=> $_[0])->hash }
177 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
179 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
183 my ($mxscore, $time, $tries, $totaltime) = @_;
184 my $score = $mxscore;
185 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
186 $score = ($totaltime - $time) / $totaltime * $score;
187 $score -= $tries / 10 * $mxscore;
188 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
194 $ct = contest_entry
$ct;
196 my @problems = query
(contest_problems_sth
=> $ct->{id
})->flat;
197 my $pblist = problem_list
;
198 my %values = query
('problem_values_sth')->map;
200 my (%scores, %tries, %opens);
201 my $opens = query
(opens_sth
=> $ct->{id
});
202 while ($opens->into(my ($problem, $owner, $time))) {
203 $opens{$problem, $owner} = $time;
206 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
208 while (my $job = $jobs->hash) {
209 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
210 my $time = $job->{date
} - $open;
211 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
212 my $value = $values{$job->{problem
}};
213 my $factor = $job->{result
} ?
0 : 1;
214 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
215 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
218 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
222 user_name
=> object_name
(users
=> $user),
223 score
=> sum
(values %{$scores{$user}}),
224 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
228 $st[0]->{rank
} = 1 if @st;
229 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
232 problems
=> [map { [ $_, object_name
(problems
=> $_)] } @problems],
237 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
240 while ($jobs->into(my ($id, $owner, $problem, $result))) {
241 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
244 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
246 my @contest_statuses = map {
248 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
($ct)->{st
}}
249 } $db->select('contests', 'id')->flat;
252 $db->delete('problem_status');
253 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
254 $db->delete('contest_status');
255 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
261 query rerun_job_sth
=> $id;
268 my $id = query
(take_job_sth
=> $daemon)->list;
269 return $id ? job_full
$id : undef;
273 my ($job, $private, %args) = @_;
274 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
277 problem
=> $job->{problem
},
278 owner
=> $job->{owner
},
280 solved
=> ($args{result
} ?
0 : 1),
283 db
->insert(problem_status
=> $status)
284 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
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.