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