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