1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_015';
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 open_problem/;
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_problem_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE problem = ?',
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 my @problems = sort { $a->{value
} <=> $b->{value
} } @
{problem_list contest
=> $ct};
186 my %values = map { $_->{id
} => $_->{value
} } @problems;
187 $ct = contest_entry
$ct;
189 my (%scores, %tries, %opens);
190 my $opens = _query
(opens_sth
=> $ct->{id
});
191 while ($opens->into(my ($problem, $owner, $time))) {
192 $opens{$problem, $owner} = $time;
195 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
197 while (my $job = $jobs->hash) {
198 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
199 my $time = $job->{date
} - $open;
200 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
201 my $value = $values{$job->{problem
}};
202 my $factor = $job->{result
} ?
0 : 1;
203 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
204 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * _calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
207 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
211 user_name
=> _object_name
(users
=> $user),
212 score
=> sum
(values %{$scores{$user}}),
213 scores
=> [map { $scores{$user}{$_->{id
}} // '-'} @problems],
217 $st[0]->{rank
} = 1 if @st;
218 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
224 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
227 while ($jobs->into(my ($id, $owner, $problem, $result))) {
228 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
231 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
233 my @contest_statuses = map {
235 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
$ct}
236 } $db->select('contests', 'id')->flat;
239 $db->delete('problem_status');
240 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
241 $db->delete('contest_status');
242 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
248 _query rerun_problem_sth
=> $problem;
254 _query rerun_job_sth
=> $id;
261 my $id = _query
(take_job_sth
=> $daemon)->list;
265 db
->select(jobs
=> '*', {id
=> $id})->hash
269 my ($job, $private, %args) = @_;
270 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
272 purge
'/log/' . $job->{id
};
275 problem
=> $job->{problem
},
276 owner
=> $job->{owner
},
278 solved
=> ($args{result
} ?
0 : 1),
281 db
->insert(problem_status
=> $status)
282 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
283 purge
'/us/' . $job->{owner
};
287 my ($contest, $problem, $owner, $time) = @_;
288 my $ct = contest_entry
($contest);
289 return unless $ct->{id
} && $time >= $ct->{start
} && $time < $ct->{stop
}; ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions)
290 eval { db
->insert(opens
=> { ## no critic (RequireCheckingReturnValueOfEval)
297 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
298 my $ht = HTTP
::Tiny
->new;
301 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
312 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
319 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
321 All functions are exported by default.
325 =item B<dbinit>(I<@args>)
327 This function connects to the database. I<@args> are the arguments
328 passed to the L<DBIx::Simple> constructor.
330 =item B<purge>(I<$url_path>)
332 Purges a relative URL from the Varnish Cache by sending PURGE
333 $url_path requests to all hosts in the PURGE_HOSTS environment
338 Returns a L<DBIx::Simple> object for interacting with the database
339 directly. Use this when no other function in this module is suitable.
343 Returns an arrayref of the top 200 users.
345 =item B<user_entry>(I<$id>)
347 Returns a hashref describing the user I<$id>.
349 =item B<problem_list>([I<%args>])
351 Returns an arrayref of problems.
353 Takes the following named arguments:
359 Only show problems owned by this user
363 Only show problems in this contest
367 If true, include private problems. Always true if contest is present.
371 If true, include problem solutions
375 =item B<problem_entry>(i<$id>, [I<$contest>])
377 Returns a hashref describing the problem I<$id>. If $contest is
378 present, contest start and stop times are included, and the solution
381 =item B<contest_list>
383 Returns an arrayref of contests.
385 =item B<contest_entry>(I<$id>)
387 Returns a hashref describing the contest I<$id>.
389 =item B<contest_has_problem>(I<$contest>, I<$problem>)
391 Returns true if the contest I<$contest> includes the problem
392 I<$problem>, false otherwise.
394 =item B<job_list>([I<%args>])
396 In scalar context, returns an arrayref of jobs. In list context,
397 returns an arrayref of jobs and a hashref of information about pages.
399 Takes the following named arguments:
405 Show this page of the job log. Defaults to 1.
409 Only show jobs submitted by this user.
413 Only show jobs submitted in this contest.
417 Only show jobs submitted for this problem.
421 Only show jobs with this result (see the constants in
422 L<Gruntmaster::Daemon::Constants>).
426 If true, include private jobs. Defaults to false.
430 =item B<job_entry>(I<$id>)
432 Returns a hashref describing the job I<$id>.
434 =item B<create_job>(I<%args>)
436 Insert a new job into the database. This function also updates the
437 lastjob field for the job's owner.
439 =item B<standings>(I<$ct>)
441 Returns an arrayref of the standings of contest I<$ct>.
443 =item B<update_status>
445 Rebuilds the problem_status and contest_status tables.
447 =item B<rerun_job>(I<$id>)
449 Marks the job $id as pending and clears its results, so that it will
450 be run again by the daemon.
452 =item B<take_job>(I<$daemon>)
454 Marks a random job as being run by I<$daemon>. Returns a hashref
455 describing the job, or undef if no job was available.
457 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
459 Updates the job $job with the results in %results. If $private is
460 false, also updates the problem_status table.
462 =item B<open_problem>(I<$contest>, I<$problem>, I<$owner>, I<$time>)
464 Notes that I<$owner> has opened the problem I<$problem> of contest
465 I<$contest> at time I<$time>. If the C<opens> table already contains
466 this (I<$contest>, I<$problem>, I<$owner>) triplet, this function does
473 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
475 =head1 COPYRIGHT AND LICENSE
477 Copyright (C) 2014-2015 by Marius Gavrilescu
479 This library is free software; you can redistribute it and/or modify
480 it under the same terms as Perl itself, either Perl version 5.20.1 or,
481 at your option, any later version of Perl 5 you may have available.