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;
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
};
279 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
280 my $ht = HTTP
::Tiny
->new;
283 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
294 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
301 Gruntmaster::Data is the interface to the Gruntmaster 6000 database.
303 All functions are exported by default.
307 =item B<dbinit>(I<@args>)
309 This function connects to the database. I<@args> are the arguments
310 passed to the L<DBIx::Simple> constructor.
312 =item B<purge>(I<$url_path>)
314 Purges a relative URL from the Varnish Cache by sending PURGE
315 $url_path requests to all hosts in the PURGE_HOSTS environment
320 Returns a L<DBIx::Simple> object for interacting with the database
321 directly. Use this when no other function in this module is suitable.
325 Returns an arrayref of the top 200 users.
327 =item B<user_entry>(I<$id>)
329 Returns a hashref describing the user I<$id>.
331 =item B<problem_list>([I<%args>])
333 Returns an arrayref of problems.
335 Takes the following named arguments:
341 Only show problems owned by this user
345 Only show problems in this contest
349 If true, include private problems. Always true if contest is present.
353 If true, include problem solutions
357 =item B<problem_entry>(i<$id>, [I<$contest>])
359 Returns a hashref describing the problem I<$id>. If $contest is
360 present, contest start and stop times are included, and the solution
363 =item B<contest_list>
365 Returns an arrayref of contests.
367 =item B<contest_entry>(I<$id>)
369 Returns a hashref describing the contest I<$id>.
371 =item B<contest_has_problem>(I<$contest>, I<$problem>)
373 Returns true if the contest I<$contest> includes the problem
374 I<$problem>, false otherwise.
376 =item B<job_list>([I<%args>])
378 In scalar context, returns an arrayref of jobs. In list context,
379 returns an arrayref of jobs and a hashref of information about pages.
381 Takes the following named arguments:
387 Show this page of the job log. Defaults to 1.
391 Only show jobs submitted by this user.
395 Only show jobs submitted in this contest.
399 Only show jobs submitted for this problem.
403 Only show jobs with this result (see the constants in
404 L<Gruntmaster::Daemon::Constants>).
408 If true, include private jobs. Defaults to false.
412 =item B<job_entry>(I<$id>)
414 Returns a hashref describing the job I<$id>.
416 =item B<create_job>(I<%args>)
418 Insert a new job into the database. This function also updates the
419 lastjob field for the job's owner.
421 =item B<standings>(I<$ct>)
423 Returns an arrayref of the standings of contest I<$ct>.
425 =item B<update_status>
427 Rebuilds the problem_status and contest_status tables.
429 =item B<rerun_job>(I<$id>)
431 Marks the job $id as pending and clears its results, so that it will
432 be run again by the daemon.
434 =item B<take_job>(I<$daemon>)
436 Marks a random job as being run by I<$daemon>. Returns a hashref
437 describing the job, or undef if no job was available.
439 =item B<finish_job>(I<$job>, I<$private>, I<%results>)
441 Updates the job $job with the results in %results. If $private is
442 false, also updates the problem_status table.
448 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
450 =head1 COPYRIGHT AND LICENSE
452 Copyright (C) 2014 by Marius Gavrilescu
454 This library is free software; you can redistribute it and/or modify
455 it under the same terms as Perl itself, either Perl version 5.18.1 or,
456 at your option, any later version of Perl 5 you may have available.