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/; ## no critic (ProhibitAutomaticExportation)
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;
255 return $id ? db
->select(jobs
=> '*', {id
=> $id})->hash : undef;
259 my ($job, $private, %args) = @_;
260 db
->update(jobs
=> \
%args, {id
=> $job->{id
}});
263 problem
=> $job->{problem
},
264 owner
=> $job->{owner
},
266 solved
=> ($args{result
} ?
0 : 1),
269 db
->insert(problem_status
=> $status)
270 } or db
->update(problem_status
=> $status, {owner
=> $job->{owner
}, problem
=> $job->{problem
}});
273 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
274 my $ht = HTTP
::Tiny
->new;
277 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
288 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
295 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
297 All functions are exported by default.
301 =item B<dbinit>(I<@args>)
303 This function connects to the database. I<@args> are the arguments
304 passed to the L<DBIx::Simple> constructor.
306 =item B<purge>(I<$url_path>)
308 Purges a relative URL from the Varnish Cache by sending PURGE
309 $url_path requests to all hosts in the PURGE_HOSTS environment
314 Returns a L<DBIx::Simple> object for interacting with the database
315 directly. Use this when no other function in this module is suitable.
319 Returns an arrayref of the top 200 users.
321 =item B<user_entry>(I<$id>)
323 Returns a hashref describing the user I<$id>.
325 =item B<problem_list>([I<%args>])
327 Returns an arrayref of problems.
329 Takes the following named arguments:
335 Only show problems owned by this user
339 Only show problems in this contest
343 If true, include private problems. Always true if contest is present.
347 If true, include problem solutions
351 =item B<problem_entry>(i<$id>, [I<$contest>])
353 Returns a hashref describing the problem I<$id>. If $contest is
354 present, contest start and stop times are included, and the solution
357 =item B<contest_list>
359 Returns an arrayref of contests.
361 =item B<contest_entry>(I<$id>)
363 Returns a hashref describing the contest I<$id>.
365 =item B<contest_has_problem>(I<$contest>, I<$problem>)
367 Returns true if the contest I<$contest> includes the problem
368 I<$problem>, false otherwise.
370 =item B<job_list>([I<%args>])
372 In scalar context, returns an arrayref of jobs. In list context,
373 returns an arrayref of jobs and a hashref of information about pages.
375 Takes the following named arguments:
381 Show this page of the job log. Defaults to 1.
385 Only show jobs submitted by this user.
389 Only show jobs submitted in this contest.
393 Only show jobs submitted for this problem.
397 Only show jobs with this result (see the constants in
398 L<Gruntmaster::Daemon::Constants>).
402 If true, include private jobs. Defaults to false.
406 =item B<job_entry>(I<$id>)
408 Returns a hashref describing the job I<$id>.
410 =item B<create_job>(I<%args>)
412 Insert a new job into the database. This function also updates the
413 lastjob field for the job's owner.
415 =item B<standings>(I<$ct>)
417 Returns an arrayref of the standings of contest I<$ct>.
419 =item B<update_status>
421 Rebuilds the problem_status and contest_status tables.
423 =item B<rerun_job>(I<$id>)
425 Marks the job $id as pending and clears its results, so that it will
426 be run again by the daemon.
428 =item B<take_job>(I<$daemon>)
430 Marks a random job as being run by I<$daemon>. Returns a hashref
431 describing the job, or undef if no job was available.
433 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
435 Updates the job $job with the results in %results. If $private is
436 false, also updates the problem_status table.
442 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
444 =head1 COPYRIGHT AND LICENSE
446 Copyright (C) 2014 by Marius Gavrilescu
448 This library is free software; you can redistribute it and/or modify
449 it under the same terms as Perl itself, either Perl version 5.18.1 or,
450 at your option, any later version of Perl 5 you may have available.