1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
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_job_sth
=> 'UPDATE jobs SET daemon=NULL,result=-2,result_text=NULL,results=NULL,errors=NULL WHERE id = ?',
40 take_job_sth
=> 'UPDATE jobs SET daemon=? WHERE id = (SELECT id FROM jobs WHERE daemon IS NULL LIMIT 1 FOR UPDATE) RETURNING id',
47 $db = DBIx
::Simple
->new(@_);
48 $db->keep_statements = 100;
54 my ($stat, @extra) = @_;
55 $db->query($statements{$stat}, @extra)
58 my (%name_cache, %name_cache_time);
59 use constant NAME_CACHE_MAX_AGE
=> 5;
62 my ($table, $id) = @_;
63 $name_cache_time{$table} //= 0;
64 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
65 $name_cache_time{$table} = time;
66 $name_cache{$table} = {};
67 $name_cache{$table} = $db->select($table, 'id,name')->map;
70 $name_cache{$table}{$id}
74 sub _add_names
($) { ## no critic (ProhibitSubroutinePrototypes)
76 return unless defined $el;
77 if (ref $el eq 'ARRAY') {
78 &_add_names
($_) for @
$el ## no critic (ProhibitAmpersandSigils)
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 _add_names
$db->select(\
$table, \
@columns, \
%where, 'name')->hashes
114 my ($id, $contest) = @_;
115 $contest = contest_entry
($contest) if $contest;
116 my $ret = _add_names _query
(problem_entry_sth
=> $id)->hash;
117 my $limits = _query
(limits_sth
=> $id)->hashes;
118 $ret->{limits
} = $limits if @
$limits;
121 $ret->{contest_start
} = $contest->{start
};
122 $ret->{contest_stop
} = $contest->{stop
};
123 delete $ret->{solution
}
129 sub contest_list
{ _add_names _query
('contest_list_sth')->hashes }
131 sub contest_entry
{ _add_names _query
(contest_entry_sth
=> $_[0])->hash }
133 sub contest_has_problem
{ _query
('contest_has_problem_sth', @_[0, 1])->flat }
137 $args{page
} = int ($args{page
} // 1);
139 maybe contest
=> $args{contest
},
140 maybe owner
=> $args{owner
},
141 maybe problem
=> $args{problem
},
142 maybe result
=> $args{result
},
144 $where{private
} = 0 unless $args{private
};
146 my $rows = $db->select('job_entry', 'COUNT(*)', \
%where)->list;
147 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
148 my ($stmt, @bind) = $db->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
149 my $jobs = _add_names
$db->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
151 current_page
=> $args{page
},
153 ($args{page
} - 1) ?
(previous_page
=> $args{page
} - 1) : (),
154 ($args{page
} < $pages) ?
(next_page
=> $args{page
} + 1) : (),
156 wantarray ?
($jobs, $pageinfo) : $jobs;
160 my $ret = _add_names _query
(job_entry_sth
=> $_[0])->hash;
161 $ret->{results
} = decode_json
$ret->{results
} if $ret->{results
};
167 $db->update('users', {lastjob
=> time}, {id
=> $args{owner
}});
169 scalar $db->insert('jobs', \
%args, {returning
=> 'id'})->list
173 my ($mxscore, $time, $tries, $totaltime) = @_;
174 my $score = $mxscore;
175 $time = 300 if $time > $totaltime; # uncoverable branch true does not happen anymore (only possible if opens are broken)
176 $score = ($totaltime - $time) / $totaltime * $score;
177 $score -= $tries / 10 * $mxscore;
178 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
184 my @problems = sort { $a->{value
} <=> $b->{value
} } @
{problem_list contest
=> $ct};
185 my %values = map { $_->{id
} => $_->{value
} } @problems;
186 $ct = contest_entry
$ct;
188 my (%scores, %tries, %opens);
189 my $opens = _query
(opens_sth
=> $ct->{id
});
190 while ($opens->into(my ($problem, $owner, $time))) {
191 $opens{$problem, $owner} = $time;
194 my $jobs = $db->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
196 while (my $job = $jobs->hash) {
197 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
198 my $time = $job->{date
} - $open;
199 next if $time < 0; # uncoverable branch true job sent before contest is deprecated
200 my $value = $values{$job->{problem
}};
201 my $factor = $job->{result
} ?
0 : 1;
202 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
203 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * _calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
206 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
210 user_name
=> _object_name
(users
=> $user),
211 score
=> sum
(values %{$scores{$user}}),
212 scores
=> [map { $scores{$user}{$_->{id
}} // '-'} @problems],
216 $st[0]->{rank
} = 1 if @st;
217 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
223 my $jobs = $db->select('jobs', 'id,owner,problem,result', {-not_bool
=> 'private'}, 'id');
226 while ($jobs->into(my ($id, $owner, $problem, $result))) {
227 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
230 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
232 my @contest_statuses = map {
234 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{standings
$ct}
235 } $db->select('contests', 'id')->flat;
238 $db->delete('problem_status');
239 $db->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
240 $db->delete('contest_status');
241 $db->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
247 _query rerun_job_sth
=> $id;
254 my $id = _query
(take_job_sth
=> $daemon)->list;
258 db
->select(jobs
=> '*', {id
=> $id})->hash
262 my ($job, $private, %args) = @_;
263 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
265 purge
'/log/' . $job->{id
};
268 problem
=> $job->{problem
},
269 owner
=> $job->{owner
},
271 solved
=> ($args{result
} ?
0 : 1),
274 db
->insert(problem_status
=> $status)
275 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
276 purge
'/us/' . $job->{owner
};
280 my ($contest, $problem, $owner, $time) = @_;
281 my $ct = contest_entry
($contest);
282 return unless $ct->{id
} && $time >= $ct->{start
} && $time < $ct->{stop
}; ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions)
283 eval { db
->insert(opens
=> { ## no critic (RequireCheckingReturnValueOfEval)
290 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
291 my $ht = HTTP
::Tiny
->new;
294 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
305 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
312 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
314 All functions are exported by default.
318 =item B<dbinit>(I<@args>)
320 This function connects to the database. I<@args> are the arguments
321 passed to the L<DBIx::Simple> constructor.
323 =item B<purge>(I<$url_path>)
325 Purges a relative URL from the Varnish Cache by sending PURGE
326 $url_path requests to all hosts in the PURGE_HOSTS environment
331 Returns a L<DBIx::Simple> object for interacting with the database
332 directly. Use this when no other function in this module is suitable.
336 Returns an arrayref of the top 200 users.
338 =item B<user_entry>(I<$id>)
340 Returns a hashref describing the user I<$id>.
342 =item B<problem_list>([I<%args>])
344 Returns an arrayref of problems.
346 Takes the following named arguments:
352 Only show problems owned by this user
356 Only show problems in this contest
360 If true, include private problems. Always true if contest is present.
364 If true, include problem solutions
368 =item B<problem_entry>(i<$id>, [I<$contest>])
370 Returns a hashref describing the problem I<$id>. If $contest is
371 present, contest start and stop times are included, and the solution
374 =item B<contest_list>
376 Returns an arrayref of contests.
378 =item B<contest_entry>(I<$id>)
380 Returns a hashref describing the contest I<$id>.
382 =item B<contest_has_problem>(I<$contest>, I<$problem>)
384 Returns true if the contest I<$contest> includes the problem
385 I<$problem>, false otherwise.
387 =item B<job_list>([I<%args>])
389 In scalar context, returns an arrayref of jobs. In list context,
390 returns an arrayref of jobs and a hashref of information about pages.
392 Takes the following named arguments:
398 Show this page of the job log. Defaults to 1.
402 Only show jobs submitted by this user.
406 Only show jobs submitted in this contest.
410 Only show jobs submitted for this problem.
414 Only show jobs with this result (see the constants in
415 L<Gruntmaster::Daemon::Constants>).
419 If true, include private jobs. Defaults to false.
423 =item B<job_entry>(I<$id>)
425 Returns a hashref describing the job I<$id>.
427 =item B<create_job>(I<%args>)
429 Insert a new job into the database. This function also updates the
430 lastjob field for the job's owner.
432 =item B<standings>(I<$ct>)
434 Returns an arrayref of the standings of contest I<$ct>.
436 =item B<update_status>
438 Rebuilds the problem_status and contest_status tables.
440 =item B<rerun_job>(I<$id>)
442 Marks the job $id as pending and clears its results, so that it will
443 be run again by the daemon.
445 =item B<take_job>(I<$daemon>)
447 Marks a random job as being run by I<$daemon>. Returns a hashref
448 describing the job, or undef if no job was available.
450 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
452 Updates the job $job with the results in %results. If $private is
453 false, also updates the problem_status table.
455 =item B<open_problem>(I<$contest>, I<$problem>, I<$owner>, I<$time>)
457 Notes that I<$owner> has opened the problem I<$problem> of contest
458 I<$contest> at time I<$time>. If the C<opens> table already contains
459 this (I<$contest>, I<$problem>, I<$owner>) triplet, this function does
466 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
468 =head1 COPYRIGHT AND LICENSE
470 Copyright (C) 2014 by Marius Gavrilescu
472 This library is free software; you can redistribute it and/or modify
473 it under the same terms as Perl itself, either Perl version 5.18.1 or,
474 at your option, any later version of Perl 5 you may have available.