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
};
273 purge
'/st/' . $job->{contest
} if $job->{contest
};
276 problem
=> $job->{problem
},
277 owner
=> $job->{owner
},
279 solved
=> ($args{result
} ?
0 : 1),
282 db
->insert(problem_status
=> $status)
283 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
284 purge
'/us/' . $job->{owner
};
288 my ($contest, $problem, $owner, $time) = @_;
289 my $ct = contest_entry
($contest);
290 return unless $ct->{id
} && $time >= $ct->{start
} && $time < $ct->{stop
}; ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions)
291 eval { db
->insert(opens
=> { ## no critic (RequireCheckingReturnValueOfEval)
298 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
299 my $ht = HTTP
::Tiny
->new;
302 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
313 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
320 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
322 All functions are exported by default.
326 =item B<dbinit>(I<@args>)
328 This function connects to the database. I<@args> are the arguments
329 passed to the L<DBIx::Simple> constructor.
331 =item B<purge>(I<$url_path>)
333 Purges a relative URL from the Varnish Cache by sending PURGE
334 $url_path requests to all hosts in the PURGE_HOSTS environment
339 Returns a L<DBIx::Simple> object for interacting with the database
340 directly. Use this when no other function in this module is suitable.
344 Returns an arrayref of the top 200 users.
346 =item B<user_entry>(I<$id>)
348 Returns a hashref describing the user I<$id>.
350 =item B<problem_list>([I<%args>])
352 Returns an arrayref of problems.
354 Takes the following named arguments:
360 Only show problems owned by this user
364 Only show problems in this contest
368 If true, include private problems. Always true if contest is present.
372 If true, include problem solutions
376 =item B<problem_entry>(i<$id>, [I<$contest>])
378 Returns a hashref describing the problem I<$id>. If $contest is
379 present, contest start and stop times are included, and the solution
382 =item B<contest_list>
384 Returns an arrayref of contests.
386 =item B<contest_entry>(I<$id>)
388 Returns a hashref describing the contest I<$id>.
390 =item B<contest_has_problem>(I<$contest>, I<$problem>)
392 Returns true if the contest I<$contest> includes the problem
393 I<$problem>, false otherwise.
395 =item B<job_list>([I<%args>])
397 In scalar context, returns an arrayref of jobs. In list context,
398 returns an arrayref of jobs and a hashref of information about pages.
400 Takes the following named arguments:
406 Show this page of the job log. Defaults to 1.
410 Only show jobs submitted by this user.
414 Only show jobs submitted in this contest.
418 Only show jobs submitted for this problem.
422 Only show jobs with this result (see the constants in
423 L<Gruntmaster::Daemon::Constants>).
427 If true, include private jobs. Defaults to false.
431 =item B<job_entry>(I<$id>)
433 Returns a hashref describing the job I<$id>.
435 =item B<create_job>(I<%args>)
437 Insert a new job into the database. This function also updates the
438 lastjob field for the job's owner.
440 =item B<standings>(I<$ct>)
442 Returns an arrayref of the standings of contest I<$ct>.
444 =item B<update_status>
446 Rebuilds the problem_status and contest_status tables.
448 =item B<rerun_job>(I<$id>)
450 Marks the job $id as pending and clears its results, so that it will
451 be run again by the daemon.
453 =item B<take_job>(I<$daemon>)
455 Marks a random job as being run by I<$daemon>. Returns a hashref
456 describing the job, or undef if no job was available.
458 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
460 Updates the job $job with the results in %results. If $private is
461 false, also updates the problem_status table.
463 =item B<open_problem>(I<$contest>, I<$problem>, I<$owner>, I<$time>)
465 Notes that I<$owner> has opened the problem I<$problem> of contest
466 I<$contest> at time I<$time>. If the C<opens> table already contains
467 this (I<$contest>, I<$problem>, I<$owner>) triplet, this function does
474 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
476 =head1 COPYRIGHT AND LICENSE
478 Copyright (C) 2014-2015 by Marius Gavrilescu
480 This library is free software; you can redistribute it and/or modify
481 it under the same terms as Perl itself, either Perl version 5.20.1 or,
482 at your option, any later version of Perl 5 you may have available.