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
  13 use File::Basename qw/fileparse/;
  14 use File::Slurp qw/write_file/;
  15 use File::Temp qw/tempdir/;
  16 use Sys::Hostname qw/hostname/;
  17 use Time::HiRes qw/time/;
  18 use Try::Tiny;
  19 use Log::Log4perl qw/get_logger/;
  20
  21 use constant PAGE_SIZE => 10;
  22
  23 ##################################################
  24
  25 sub safe_can_nodie {
  26   my ($type, $sub, $name) = @_;
  27
  28   return unless $name =~ /^\w+$/;
  29   no strict 'refs';
  30   my $pkg = __PACKAGE__ . "::${type}::${name}";
  31   eval "require $pkg" or get_logger->warn("Error while requiring $pkg: $@");
  32   $pkg->can($sub);
  33 }
  34
  35 sub safe_can {
  36   my ($type, $sub, $name) = @_;
  37
  38   safe_can_nodie @_ or get_logger->logdie("No such \l$type: '$name'");
  39 }
  40
  41 sub prepare{
  42   my ($name, $format) = @_;
  43   our $errors;
  44   my $basename = fileparse $name, qr/\.[^.]*/;
  45   get_logger->trace("Preparing file $name...");
  46
  47   $errors .= `gruntmaster-compile $format $basename $name 2>&1`;
  48   $errors .= "\n";
  49   die 'Compile error' if $?
  50 }
  51
  52 sub prepare_files{
  53   my $meta = shift;
  54
  55   for my $file (values $meta->{files}) {
  56         my ($format, $name, $content) = @{$file}{qw/format name content/};
  57
  58         $file->{run} = mkrun($format);
  59         write_file $name, $content;
  60         prepare $name, $format;
  61   }
  62 }
  63
  64 sub process{
  65   my $job = shift;
  66
  67   my @results;
  68   my @full_results = ();
  69   my $meta = {};
  70   our $errors = '';
  71   try {
  72         $meta = job_inmeta $job;
  73         if (job_problem $job) {
  74           my $pbmeta = problem_meta job_problem $job;
  75           my %files = exists $meta->{files} ? %{$meta->{files}} : ();
  76           $meta = {%$meta, %$pbmeta};
  77           $meta->{files} = {%files, %{$pbmeta->{files}}} if exists $pbmeta->{files};
  78         }
  79
  80         prepare_files $meta;
  81         chomp $errors;
  82
  83         my ($files, $generator, $runner, $judge, $testcnt) = map { $meta->{$_} or die "Required parameter missing: $_"} qw/files generator runner judge testcnt/;
  84
  85         $generator = safe_can Generator => generate => $generator;
  86         $runner = safe_can Runner => run => $runner;
  87         $judge = safe_can Judge => judge => $judge;
  88
  89         for my $test (1 .. $testcnt) {
  90           my $start_time = time;
  91           my $result;
  92           try {
  93                 $generator->($test, $meta);
  94                 $result = $runner->($test, $meta);
  95           } catch {
  96                 $result = $_;
  97                 unless (ref $result) {
  98                   chomp $result;
  99                   $result = [ERR, $result];
 100                 }
 101           };
 102
 103           if (ref $result) {
 104                 get_logger->trace("Test $test result is " . $result->[1]);
 105                 push @full_results, {id => $test, result => $result->[0], result_text => $result->[1], time => time - $start_time}
 106           } else {
 107                 get_logger->trace("Test $test result is $result");
 108                 push @full_results, {id => $test, result => 0, result_text => $result, time => time - $start_time}
 109           }
 110           push @results, $result;
 111           last if $meta->{judge} eq 'Absolute' && ref $result
 112         }
 113
 114         my %results = $judge->(@results);
 115         $meta->{$_} = $results{$_} for keys %results;
 116   } catch {
 117         s,(.*) at .*,$1,;
 118         chomp;
 119         $meta->{result} = -1;
 120         $meta->{result_text} = $_;
 121   };
 122
 123   get_logger->info("Job result: " . $meta->{result_text});
 124   set_job_result $job, $meta->{result};
 125   set_job_result_text $job, $meta->{result_text};
 126   set_job_results $job, \@full_results if scalar @full_results;
 127   set_job_errors $job, $errors;
 128
 129   my $log = $Gruntmaster::Data::contest ? "ct/$Gruntmaster::Data::contest/log" : 'log';
 130
 131   PUBLISH gensrc => ($Gruntmaster::Data::contest // '') . ".$job";
 132   PUBLISH genpage => "$log/job/$job.html";
 133   PUBLISH genpage => "$log/index.html";
 134   PUBLISH genpage => "$log/st.html";
 135   my $page = ($job + PAGE_SIZE - 1) / PAGE_SIZE;
 136   PUBLISH genpage => "$log/@{[$page - 1]}.html";
 137   PUBLISH genpage => "$log/$page.html";
 138   PUBLISH genpage => "$log/@{[$page + 1]}.html";
 139 }
 140
 141 sub got_job{
 142         $_[0] =~ /^(\w*)\.(\d+)$/;
 143         my $job = $2;
 144         local $Gruntmaster::Data::contest = $1 if $1;
 145         get_logger->debug("Taking job $job@{[defined $1 ? \" of contest $1\" : '']}...");
 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