1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_016';
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 rerun_problem 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 # result IS NULL if job was never run
196 # result = -2 if job is being rerun
197 my %where = (contest
=> $ct->{id
}, result
=> {'>=', 0});
198 my $jobs = $db->select('job_entry', '*', \
%where, 'id');
200 while (my $job = $jobs->hash) {
201 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
202 my $time = $job->{date
} - $open;
203 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
204 my $value = $values{$job->{problem
}};
205 my $factor = $job->{result
} ?
0 : 1;
206 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
207 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * _calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
210 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
214 user_name
=> _object_name
(users
=> $user),
215 score
=> sum
(values %{$scores{$user}}),
216 scores
=> [map { $scores{$user}{$_->{id
}} // '-'} @problems],
220 $st[0]->{rank
} = 1 if @st;
221 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
227 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
230 while ($jobs->into(my ($id, $owner, $problem, $result))) {
231 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
234 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
236 my @contest_statuses = map {
238 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
$ct}
239 } $db->select('contests', 'id')->flat;
242 $db->delete('problem_status');
243 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
244 $db->delete('contest_status');
245 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
251 _query rerun_problem_sth
=> $problem;
257 _query rerun_job_sth
=> $id;
264 my $id = _query
(take_job_sth
=> $daemon)->list;
268 db
->select(jobs
=> '*', {id
=> $id})->hash
272 my ($job, $private, %args) = @_;
273 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
275 purge
'/log/' . $job->{id
};
276 purge
'/st/' . $job->{contest
} if $job->{contest
};
279 problem
=> $job->{problem
},
280 owner
=> $job->{owner
},
282 solved
=> ($args{result
} ?
0 : 1),
285 db
->insert(problem_status
=> $status)
286 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
287 purge
'/us/' . $job->{owner
};
291 my ($contest, $problem, $owner, $time) = @_;
292 my $ct = contest_entry
($contest);
293 return unless $ct->{id
} && $time >= $ct->{start
} && $time < $ct->{stop
}; ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions)
294 eval { db
->insert(opens
=> { ## no critic (RequireCheckingReturnValueOfEval)
301 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
302 my $ht = HTTP
::Tiny
->new;
305 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
316 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
323 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
325 All functions are exported by default.
329 =item B<dbinit>(I<@args>)
331 This function connects to the database. I<@args> are the arguments
332 passed to the L<DBIx::Simple> constructor.
334 =item B<purge>(I<$url_path>)
336 Purges a relative URL from the Varnish Cache by sending PURGE
337 $url_path requests to all hosts in the PURGE_HOSTS environment
342 Returns a L<DBIx::Simple> object for interacting with the database
343 directly. Use this when no other function in this module is suitable.
347 Returns an arrayref of the top 200 users.
349 =item B<user_entry>(I<$id>)
351 Returns a hashref describing the user I<$id>.
353 =item B<problem_list>([I<%args>])
355 Returns an arrayref of problems.
357 Takes the following named arguments:
363 Only show problems owned by this user
367 Only show problems in this contest
371 If true, include private problems. Always true if contest is present.
375 If true, include problem solutions
379 =item B<problem_entry>(i<$id>, [I<$contest>])
381 Returns a hashref describing the problem I<$id>. If $contest is
382 present, contest start and stop times are included, and the solution
385 =item B<contest_list>
387 Returns an arrayref of contests.
389 =item B<contest_entry>(I<$id>)
391 Returns a hashref describing the contest I<$id>.
393 =item B<contest_has_problem>(I<$contest>, I<$problem>)
395 Returns true if the contest I<$contest> includes the problem
396 I<$problem>, false otherwise.
398 =item B<job_list>([I<%args>])
400 In scalar context, returns an arrayref of jobs. In list context,
401 returns an arrayref of jobs and a hashref of information about pages.
403 Takes the following named arguments:
409 Show this page of the job log. Defaults to 1.
413 Only show jobs submitted by this user.
417 Only show jobs submitted in this contest.
421 Only show jobs submitted for this problem.
425 Only show jobs with this result (see the constants in
426 L<Gruntmaster::Daemon::Constants>).
430 If true, include private jobs. Defaults to false.
434 =item B<job_entry>(I<$id>)
436 Returns a hashref describing the job I<$id>.
438 =item B<create_job>(I<%args>)
440 Insert a new job into the database. This function also updates the
441 lastjob field for the job's owner.
443 =item B<standings>(I<$ct>)
445 Returns an arrayref of the standings of contest I<$ct>.
447 =item B<update_status>
449 Rebuilds the problem_status and contest_status tables.
451 =item B<rerun_job>(I<$id>)
453 Marks the job $id as pending and clears its results, so that it will
454 be run again by the daemon.
456 =item B<take_job>(I<$daemon>)
458 Marks a random job as being run by I<$daemon>. Returns a hashref
459 describing the job, or undef if no job was available.
461 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
463 Updates the job $job with the results in %results. If $private is
464 false, also updates the problem_status table.
466 =item B<open_problem>(I<$contest>, I<$problem>, I<$owner>, I<$time>)
468 Notes that I<$owner> has opened the problem I<$problem> of contest
469 I<$contest> at time I<$time>. If the C<opens> table already contains
470 this (I<$contest>, I<$problem>, I<$owner>) triplet, this function does
477 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
479 =head1 COPYRIGHT AND LICENSE
481 Copyright (C) 2014-2016 by Marius Gavrilescu
483 This library is free software; you can redistribute it and/or modify
484 it under the same terms as Perl itself, either Perl version 5.20.1 or,
485 at your option, any later version of Perl 5 you may have available.