Commit | Line | Data |
---|---|---|
5c5cd38a MG |
1 | package Gruntmaster::Daemon; |
2 | ||
3 | use 5.014000; | |
4 | use strict; | |
5 | use warnings; | |
6 | ||
7 | our $VERSION = '0.001'; | |
8 | ||
9 | use Gruntmaster::Daemon::Constants qw/ERR/; | |
ddceb393 | 10 | use Gruntmaster::Daemon::Format qw/mkrun/; |
5c5cd38a | 11 | use Gruntmaster::Page qw/generate/; |
ab436d78 | 12 | use Gruntmaster::Data qw/job_inmeta job_problem problem_meta set_job_daemon set_job_result set_job_result_text set_job_results/; |
5c5cd38a | 13 | |
ab436d78 MG |
14 | use Cwd qw/cwd/; |
15 | use File::Basename qw/fileparse/; | |
16 | use File::Slurp qw/write_file/; | |
17 | use File::Spec::Functions qw/devnull/; | |
18 | use File::Temp qw/tempdir/; | |
5c5cd38a | 19 | use IO::File; |
ab436d78 MG |
20 | use IPC::Open3 qw/open3/; |
21 | use Redis; | |
22 | use Sys::Hostname qw/hostname/; | |
5c5cd38a MG |
23 | use Time::HiRes qw/time/; |
24 | use Try::Tiny; | |
25 | use YAML::Any qw/LoadFile DumpFile/; | |
26 | use Log::Log4perl qw/get_logger/; | |
ab436d78 | 27 | use Data::Dumper qw/Dumper/; |
5c5cd38a MG |
28 | |
29 | ################################################## | |
30 | ||
31 | sub safe_can_nodie { | |
32 | my ($type, $sub, $name) = @_; | |
33 | ||
34 | return unless $name =~ /^\w+$/; | |
35 | no strict 'refs'; | |
36 | my $pkg = __PACKAGE__ . "::${type}::${name}"; | |
37 | eval "require $pkg" or get_logger->warn("Error while requiring $pkg: $@"); | |
38 | $pkg->can($sub); | |
39 | } | |
40 | ||
41 | sub safe_can { | |
42 | my ($type, $sub, $name) = @_; | |
43 | ||
44 | safe_can_nodie @_ or get_logger->logdie("No such \l$type: '$name'"); | |
45 | } | |
46 | ||
ddceb393 | 47 | sub prepare{ |
ab436d78 | 48 | my ($name, $format) = @_; |
ddceb393 MG |
49 | my $basename = fileparse $name, qr/\.[^.]*/; |
50 | get_logger->trace("Preparing file $name..."); | |
51 | ||
52 | open my $devnull, devnull; | |
53 | open my $errors, '>>compile-error'; | |
ab436d78 | 54 | my $ret = open3 $devnull, $errors, undef, 'gruntmaster-compile', $format => $basename, $name; |
ddceb393 MG |
55 | waitpid $ret, 0; |
56 | close $devnull; | |
57 | close $errors; | |
58 | die 'Compile error' if $? | |
59 | } | |
60 | ||
5c5cd38a | 61 | sub prepare_files{ |
ab436d78 | 62 | my $meta = shift; |
5c5cd38a MG |
63 | |
64 | for my $file (values $meta->{files}) { | |
ab436d78 | 65 | my ($format, $name, $content) = @{$file}{qw/format name content/}; |
5c5cd38a | 66 | |
ddceb393 | 67 | $file->{run} = mkrun($format); |
ab436d78 MG |
68 | write_file $name, $content; |
69 | prepare $name, $format; | |
5c5cd38a MG |
70 | } |
71 | } | |
72 | ||
ab436d78 | 73 | my $tempdir; |
5c5cd38a | 74 | |
ab436d78 MG |
75 | sub process{ |
76 | my $job = shift; | |
77 | my $rootdir = cwd; | |
78 | chdir $tempdir; | |
5c5cd38a MG |
79 | |
80 | my @results; | |
81 | my @full_results = (); | |
82 | my $meta = {}; | |
83 | try { | |
ab436d78 MG |
84 | $meta = job_inmeta $job; |
85 | if (job_problem $job) { | |
86 | my $pbmeta = problem_meta job_problem $job; | |
87 | my %files = %{$meta->{files}}; | |
5c5cd38a | 88 | $meta = {%$meta, %$pbmeta}; |
ab436d78 | 89 | $meta->{files} = {%files, %{$pbmeta->{files}}} if exists $pbmeta->{files}; |
5c5cd38a MG |
90 | } |
91 | ||
ab436d78 MG |
92 | prepare_files $meta; |
93 | say Dumper $meta; | |
94 | ||
5c5cd38a MG |
95 | my ($files, $generator, $runner, $judge, $testcnt) = map { $meta->{$_} or die "Required parameter missing: $_"} qw/files generator runner judge testcnt/; |
96 | ||
97 | $generator = safe_can Generator => generate => $generator; | |
98 | $runner = safe_can Runner => run => $runner; | |
99 | $judge = safe_can Judge => judge => $judge; | |
100 | ||
5c5cd38a MG |
101 | for my $test (1 .. $testcnt) { |
102 | my $start_time = time; | |
103 | my $result; | |
104 | try { | |
105 | $generator->($test, $meta); | |
106 | $result = $runner->($test, $meta); | |
107 | } catch { | |
108 | $result = $_; | |
109 | unless (ref $result) { | |
110 | chomp $result; | |
111 | $result = [ERR, $result]; | |
112 | } | |
113 | }; | |
114 | ||
115 | if (ref $result) { | |
116 | get_logger->trace("Test $test result is " . $result->[1]); | |
117 | push @full_results, {id => $test, result => $result->[0], result_text => $result->[1], time => time - $start_time} | |
118 | } else { | |
119 | get_logger->trace("Test $test result is $result"); | |
120 | push @full_results, {id => $test, result => 0, result_text => $result, time => time - $start_time} | |
121 | } | |
122 | push @results, $result; | |
123 | last if $meta->{judge} eq 'Absolute' && ref $result | |
124 | } | |
125 | ||
126 | my %results = $judge->(@results); | |
127 | $meta->{$_} = $results{$_} for keys %results; | |
128 | } catch { | |
129 | s,(.*) at .*,$1,; | |
130 | chomp; | |
131 | $meta->{result} = -1; | |
132 | $meta->{result_text} = $_; | |
133 | }; | |
134 | ||
5c5cd38a | 135 | get_logger->info("Job result: " . $meta->{result_text}); |
ab436d78 MG |
136 | set_job_result $job, $meta->{result}; |
137 | set_job_result_text $job, $meta->{result_text}; | |
138 | set_job_results $job, \@full_results if scalar @full_results; | |
139 | ||
140 | chdir $rootdir; | |
141 | my $log = $meta->{contest} ? "ct/$meta->{contest}/log" : 'log'; | |
142 | write_file "$log/src/$job." . Gruntmaster::Page::Log::FORMAT_EXTENSION->{$meta->{files}{prog}{format}}, $meta->{files}{prog}{content}; | |
143 | generate "$log/job/$job.html"; | |
144 | my $page = ($job + Gruntmaster::Page::Log::PAGE_SIZE - 1) / Gruntmaster::Page::Log::PAGE_SIZE; | |
145 | generate "$log/$page.html" | |
146 | } | |
147 | ||
148 | sub got_job{ | |
149 | my $job = shift; | |
150 | get_logger->debug("Taking job $job..."); | |
151 | if (set_job_daemon $job, hostname . ":$$") { | |
152 | get_logger->debug("Succesfully taken job $job"); | |
153 | process $job; | |
154 | get_logger->debug("Job $job done"); | |
155 | } else { | |
156 | get_logger->debug("Job $job already taken"); | |
157 | } | |
5c5cd38a MG |
158 | } |
159 | ||
160 | sub run{ | |
161 | Log::Log4perl->init('log.conf'); | |
ab436d78 MG |
162 | get_logger->info("gruntmasterd $VERSION started"); |
163 | $tempdir = tempdir 'gruntmasterd.XXXX', CLEANUP => 1, TMPDIR => 1; | |
164 | my $redis = Redis->new; | |
165 | $redis->subscribe('jobs', \&got_job); | |
166 | $redis->wait_for_messages(0) while 1 | |
5c5cd38a MG |
167 | } |
168 | ||
169 | 1; | |
170 | __END__ | |
171 | # Below is stub documentation for your module. You'd better edit it! | |
172 | ||
173 | =head1 NAME | |
174 | ||
175 | Gruntmaster::Daemon - Perl extension for blah blah blah | |
176 | ||
177 | =head1 SYNOPSIS | |
178 | ||
179 | use Gruntmaster::Daemon; | |
180 | blah blah blah | |
181 | ||
182 | =head1 DESCRIPTION | |
183 | ||
184 | Stub documentation for Gruntmaster::Daemon, created by h2xs. It looks like the | |
185 | author of the extension was negligent enough to leave the stub | |
186 | unedited. | |
187 | ||
188 | Blah blah blah. | |
189 | ||
190 | ||
191 | =head1 SEE ALSO | |
192 | ||
193 | Mention other useful documentation such as the documentation of | |
194 | related modules or operating system documentation (such as man pages | |
195 | in UNIX), or any relevant external documentation such as RFCs or | |
196 | standards. | |
197 | ||
198 | If you have a mailing list set up for your module, mention it here. | |
199 | ||
200 | If you have a web site set up for your module, mention it here. | |
201 | ||
202 | =head1 AUTHOR | |
203 | ||
204 | Marius Gavrilescu, E<lt>marius@E<gt> | |
205 | ||
206 | =head1 COPYRIGHT AND LICENSE | |
207 | ||
208 | Copyright (C) 2013 by Marius Gavrilescu | |
209 | ||
210 | This library is free software; you can redistribute it and/or modify | |
211 | it under the same terms as Perl itself, either Perl version 5.18.1 or, | |
212 | at your option, any later version of Perl 5 you may have available. | |
213 | ||
214 | ||
215 | =cut |