1d8cb8b41c80b18cebba926f702ca670e05e6c45
[gruntmaster-daemon.git] / lib / Gruntmaster / Daemon.pm
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/;
10 use Gruntmaster::Daemon::Format qw/mkrun/;
11 use Gruntmaster::Page qw/generate/;
12 use Gruntmaster::Data qw/job_inmeta job_problem problem_meta set_job_daemon set_job_result set_job_result_text set_job_results/;
13
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/;
19 use IO::File;
20 use IPC::Open3 qw/open3/;
21 use Redis;
22 use Sys::Hostname qw/hostname/;
23 use Time::HiRes qw/time/;
24 use Try::Tiny;
25 use YAML::Any qw/LoadFile DumpFile/;
26 use Log::Log4perl qw/get_logger/;
27 use Data::Dumper qw/Dumper/;
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
47 sub prepare{
48 my ($name, $format) = @_;
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';
54 my $ret = open3 $devnull, $errors, undef, 'gruntmaster-compile', $format => $basename, $name;
55 waitpid $ret, 0;
56 close $devnull;
57 close $errors;
58 die 'Compile error' if $?
59 }
60
61 sub prepare_files{
62 my $meta = shift;
63
64 for my $file (values $meta->{files}) {
65 my ($format, $name, $content) = @{$file}{qw/format name content/};
66
67 $file->{run} = mkrun($format);
68 write_file $name, $content;
69 prepare $name, $format;
70 }
71 }
72
73 my $tempdir;
74
75 sub process{
76 my $job = shift;
77 my $rootdir = cwd;
78 chdir $tempdir;
79
80 my @results;
81 my @full_results = ();
82 my $meta = {};
83 try {
84 $meta = job_inmeta $job;
85 if (job_problem $job) {
86 my $pbmeta = problem_meta job_problem $job;
87 my %files = %{$meta->{files}};
88 $meta = {%$meta, %$pbmeta};
89 $meta->{files} = {%files, %{$pbmeta->{files}}} if exists $pbmeta->{files};
90 }
91
92 prepare_files $meta;
93 say Dumper $meta;
94
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
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
135 get_logger->info("Job result: " . $meta->{result_text});
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 }
158 }
159
160 sub run{
161 Log::Log4perl->init('log.conf');
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
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
This page took 0.032874 seconds and 3 git commands to generate.