1 package Gruntmaster
::Data
;
5 use parent qw
/Exporter/;
6 our $VERSION = '5999.000_013';
7 our @EXPORT = qw
/purge/; ## no critic (ProhibitAutomaticExportation)
9 use JSON
::MaybeXS qw
/decode_json/;
11 use PerlX
::Maybe qw
/maybe/;
15 use List
::Util qw
/sum/;
18 use constant CONTEST_PUBLIC_COLUMNS
=> [qw
/id name description start stop owner/];
19 use constant PROBLEM_PUBLIC_COLUMNS
=> [qw
/id author writer level name owner private timeout olimit value/];
20 use constant USER_PUBLIC_COLUMNS
=> [qw
/id admin name town university country level/];
21 use constant JOBS_PER_PAGE
=> 50;
24 user_list_sth
=> 'SELECT * FROM user_list LIMIT 200',
25 user_entry_sth
=> 'SELECT * FROM user_data WHERE id = ?',
27 problem_status_sth
=> 'SELECT problem,solved FROM problem_status WHERE owner = ?',
28 contest_status_sth
=> 'SELECT contest,score,rank FROM contest_status WHERE owner = ?',
30 contest_list_sth
=> 'SELECT * FROM contest_entry',
31 contest_entry_sth
=> 'SELECT * FROM contest_entry WHERE id = ?',
32 contest_full_sth
=> 'SELECT * FROM contests WHERE id = ?',
33 contest_problems_sth
=> 'SELECT problem FROM contest_problems JOIN problems pb ON problem=pb.id WHERE contest = ? ORDER BY pb.value',
34 contest_has_problem_sth
=> 'SELECT EXISTS(SELECT 1 FROM contest_problems WHERE contest = ? AND problem = ?)',
35 opens_sth
=> 'SELECT problem,owner,time FROM opens WHERE contest = ?',
37 problem_entry_sth
=> 'SELECT ' . (join ',', @
{PROBLEM_PUBLIC_COLUMNS
()}, 'statement', 'solution') . ' FROM problems WHERE id = ?',
38 limits_sth
=> 'SELECT format,timeout FROM limits WHERE problem = ?',
39 problem_values_sth
=> 'SELECT id,value FROM problems',
41 job_entry_sth
=> 'SELECT * FROM job_entry WHERE id = ?',
42 job_full_sth
=> 'SELECT * FROM jobs WHERE id = ?',
46 my ($class, @args) = @_;
49 dbis
=> DBIx
::Simple
->new(@args),
51 $self->{dbis
}->keep_statements = 100;
58 my ($self, $stat, @extra) = @_;
59 $self->{dbis
}->query($statements{$stat} // $stat, @extra)
62 my (%name_cache, %name_cache_time);
63 use constant NAME_CACHE_MAX_AGE
=> 5;
66 my ($self, $table, $id) = @_;
67 $name_cache_time{$table} //= 0;
68 if (time - $name_cache_time{$table} > NAME_CACHE_MAX_AGE
) {
69 $name_cache_time{$table} = time;
70 $name_cache{$table} = {};
71 $name_cache{$table} = $self->{dbis
}->select($table, 'id,name')->map;
74 $name_cache{$table}{$id}
80 if (ref $el eq 'ARRAY') {
81 $self->add_names($_) for @
$el
83 for my $object (qw
/contest owner problem/) {
84 my $table = $object eq 'owner' ?
'users' : "${object}s";
85 $el->{"${object}_name"} = $self->object_name($table, $el->{$object}) if defined $el->{$object}
94 scalar $self->query('user_list_sth')->hashes
99 my $ret = $self->query('user_entry_sth', $id)->hash;
100 $ret->{problems
} = $self->query('problem_status_sth', $id)->hashes;
101 $ret->{contests
} = $self->query('contest_status_sth', $id)->hashes;
103 $self->add_names($ret->{problems
});
104 $self->add_names($ret->{contests
});
109 my ($self, %args) = @_;
110 my @columns = @
{PROBLEM_PUBLIC_COLUMNS
()};
111 push @columns, 'solution' if $args{solution
};
113 $where{private
} = 0 unless $args{contest
} || $args{private
};
114 $where{'cp.contest'} = $args{contest
} if $args{contest
};
115 $where{owner
} = $args{owner
} if $args{owner
};
117 my $table = $args{contest
} ?
'problems JOIN contest_problems cp ON cp.problem = id' : 'problems';
118 my $ret = $self->{dbis
}->select(\
$table, \
@columns, \
%where, 'name')->hashes;
119 $self->add_names($ret);
123 $params{$_->{level
}} //= [];
124 push @
{$params{$_->{level
}}}, $_
130 my ($self, $id, $contest, $user) = @_;
131 $contest &&= $self->contest_entry($contest);
132 my $ret = $self->query(problem_entry_sth
=> $id)->hash;
133 $self->add_names($ret);
134 my $limits = $self->query(limits_sth
=> $id)->hashes;
135 $ret->{limits
} = $limits if @
$limits;
138 $ret->{contest_start
} = $contest->{start
};
139 $ret->{contest_stop
} = $contest->{stop
};
147 my $ret = $self->query('contest_list_sth')->hashes;
148 $self->add_names($ret);
152 my $state = $_->{finished
} ?
'finished' : $_->{started
} ?
'running' : 'pending';
154 push @
{$ret{$state}}, $_;
161 my ($self, $id) = @_;
162 my $ret = $self->query(contest_entry_sth
=> $id)->hash;
163 $self->add_names($ret);
167 my ($self, $id) = @_;
168 scalar $self->query(contest_full_sth
=> $id)->hash;
171 sub contest_has_problem
{
172 my ($self, $contest, $problem) = @_;
173 $self->query('contest_has_problem_sth')->flat
177 my ($self, %args) = @_;
180 maybe contest
=> $args{contest
},
181 maybe owner
=> $args{owner
},
182 maybe problem
=> $args{problem
},
183 maybe result
=> $args{result
},
185 $where{private
} = 0 unless $args{private
};
187 my $rows = $self->{dbis
}->select('job_entry', 'COUNT(*)', \
%where)->list;
188 my $pages = int (($rows + JOBS_PER_PAGE
- 1) / JOBS_PER_PAGE
);
189 my ($stmt, @bind) = $self->{dbis
}->abstract->select('job_entry', '*', \
%where, {-desc
=> 'id'});
190 my $jobs = $self->{dbis
}->query("$stmt LIMIT " . JOBS_PER_PAGE
. ' OFFSET ' . ($args{page
} - 1) * JOBS_PER_PAGE
, @bind)->hashes;
193 current_page
=> $args{page
},
196 $self->add_names($ret{log});
197 $ret{previous_page
} = $args{page
} - 1 if $args{page
} - 1;
198 $ret{next_page
} = $args{page
} + 1 if $args{page
} < $pages;
204 my ($self, $id) = @_;
205 my $ret = $self->query(job_entry_sth
=> $id)->hash;
206 $ret->{results
} &&= decode_json
$ret->{results
};
207 $self->add_names($ret);
211 my ($self, $id) = @_;
212 scalar $self->query(job_full_sth
=> $id)->hash
216 my ($self, %args) = @_;
217 $self->{dbis
}->update('users', {lastjob
=> time});
219 scalar $self->{dbis
}->insert('jobs', \
%args, {returning
=> 'id'})->list
223 my ($mxscore, $time, $tries, $totaltime) = @_;
224 my $score = $mxscore;
225 $time = 0 if $time < 0;
226 $time = 300 if $time > $totaltime;
227 $score = ($totaltime - $time) / $totaltime * $score;
228 $score -= $tries / 10 * $mxscore;
229 $score = $mxscore * 3 / 10 if $score < $mxscore * 3 / 10;
234 my ($self, $ct) = @_;
235 $ct = $self->contest_entry($ct);
237 my @problems = $self->query(contest_problems_sth
=> $ct->{id
})->flat;
238 my $pblist = $self->problem_list;
239 my %values = $self->query('problem_values_sth')->map;
240 # $values{$_} = $values{$_}->{value} for keys %values;
242 my (%scores, %tries, %opens);
243 my $opens = $self->query(opens_sth
=> $ct->{id
});
244 while ($opens->into(my ($problem, $owner, $time))) {
245 $opens{$problem, $owner} = $time;
248 my $jobs = $self->{dbis
}->select('job_entry', '*', {contest
=> $ct->{id
}}, 'id');
250 while (my $job = $jobs->hash) {
251 my $open = $opens{$job->{problem
}, $job->{owner
}} // $ct->{start
};
252 my $time = $job->{date
} - $open;
254 my $value = $values{$job->{problem
}};
255 my $factor = $job->{result
} ?
0 : 1;
256 $factor = $1 / 100 if $job->{result_text} =~ /^(\d
+ )/s
;
257 $scores{$job->{owner
}}{$job->{problem
}} = int ($factor * calc_score
($value, $time, $tries{$job->{owner
}}{$job->{problem
}}++, $ct->{stop
} - $ct->{start
}));
260 my @st = sort { $b->{score
} <=> $a->{score
} or $a->{user
} cmp $b->{user
} } map { ## no critic (ProhibitReverseSortBlock)
264 user_name
=> $self->object_name(users
=> $user),
265 score
=> sum
(values %{$scores{$user}}),
266 scores
=> [map { $scores{$user}{$_} // '-'} @problems],
270 $st[0]->{rank
} = 1 if @st;
271 $st[$_]->{rank
} = $st[$_ - 1]->{rank
} + ($st[$_]->{score
} < $st[$_ - 1]->{score
}) for 1 .. $#st;
274 problems
=> [map { [ $_, $self->object_name(problems
=> $_)] } @problems],
280 my $jobs = $self->{dbis
}->select('jobs', 'id,owner,problem,result', {}, 'id');
283 while ($jobs->into(my ($id, $owner, $problem, $result))) {
284 $hash{$problem, $owner} = [$id, $result ?
0 : 1];
287 my @problem_statuses = map { [split ($;), @
{$hash{$_}} ] } keys %hash;
289 my @contest_statuses = map {
291 map { [$ct, $_->{user
}, $_->{score
}, $_->{rank
}] } @
{$self->standings($ct)->{st
}}
292 } $self->{dbis
}->select('contests', 'id')->flat;
294 $self->{dbis
}->begin;
295 $self->{dbis
}->delete('problem_status');
296 $self->{dbis
}->query('INSERT INTO problem_status (problem,owner,job,solved) VALUES (??)', @
$_) for @problem_statuses;
297 $self->{dbis
}->delete('contest_status');
298 $self->{dbis
}->query('INSERT INTO contest_status (contest,owner,score,rank) VALUES (??)', @
$_) for @contest_statuses;
299 $self->{dbis
}->commit
302 my @PURGE_HOSTS = exists $ENV{PURGE_HOSTS
} ?
split ' ', $ENV{PURGE_HOSTS
} : ();
303 my $ht = HTTP
::Tiny
->new;
306 $ht->request(PURGE
=> "http://$_$_[0]") for @PURGE_HOSTS;
317 Gruntmaster::Data - Gruntmaster 6000 Online Judge -- database interface and tools
321 my $db = Gruntmaster::Data->connect('dbi:Pg:');
323 my $problem = $db->problem('my_problem');
324 $problem->update({timeout => 2.5}); # Set time limit to 2.5 seconds
325 $problem->rerun; # And rerun all jobs for this problem
329 my $contest = $db->contests->create({ # Create a new contest
331 name => 'My Awesome Contest',
335 $db->contest_problems->create({ # Add a problem to the contest
336 contest => 'my_contest',
337 problem => 'my_problem',
340 say 'The contest has not started yet' if $contest->is_pending;
344 my @jobs = $db->jobs->search({contest => 'my_contest', owner => 'MGV'})->all;
345 $_->rerun for @jobs; # Rerun all jobs sent by MGV in my_contest
349 Gruntmaster::Data is the interface to the Gruntmaster 6000 database. Read the L<DBIx::Class> documentation for usage information.
351 In addition to the typical DBIx::Class::Schema methods, this module contains several convenience methods:
357 Equivalent to C<< $schema->resultset('Contest') >>
359 =item contest_problems
361 Equivalent to C<< $schema->resultset('ContestProblem') >>
365 Equivalent to C<< $schema->resultset('Job') >>
369 Equivalent to C<< $schema->resultset('Problem') >>
373 Equivalent to C<< $schema->resultset('User') >>
377 Equivalent to C<< $schema->resultset('Contest')->find($id) >>
381 Equivalent to C<< $schema->resultset('Job')->find($id) >>
385 Equivalent to C<< $schema->resultset('Problem')->find($id) >>
389 Equivalent to C<< $schema->resultset('User')->find($id) >>
393 Returns a list of users as an arrayref containing hashrefs.
395 =item user_entry($id)
397 Returns a hashref with information about the user $id.
399 =item problem_list([%args])
401 Returns a list of problems grouped by level. A hashref with levels as keys.
403 Takes the following arguments:
409 Only show problems owned by this user
413 Only show problems in this contest
417 =item problem_entry($id, [$contest, $user])
419 Returns a hashref with information about the problem $id. If $contest and $user are present, problem open data is updated.
421 =item contest_list([%args])
423 Returns a list of contests grouped by state. A hashref with the following keys:
429 An arrayref of hashrefs representing pending contests
433 An arrayref of hashrefs representing running contests
437 An arrayref of hashrefs representing finished contests
441 Takes the following arguments:
447 Only show contests owned by this user.
451 =item contest_entry($id)
453 Returns a hashref with information about the contest $id.
455 =item job_list([%args])
457 Returns a list of jobs as an arrayref containing hashrefs. Takes the following arguments:
463 Only show jobs submitted by this user.
467 Only show jobs submitted in this contest.
471 Only show jobs submitted for this problem.
475 Show this page of results. Defaults to 1. Pages have 10 entries, and the first page has the most recent jobs.
481 Returns a hashref with information about the job $id.
487 Marius Gavrilescu E<lt>marius@ieval.roE<gt>
489 =head1 COPYRIGHT AND LICENSE
491 Copyright (C) 2014 by Marius Gavrilescu
493 This library is free software; you can redistribute it and/or modify
494 it under the same terms as Perl itself, either Perl version 5.18.1 or,
495 at your option, any later version of Perl 5 you may have available.