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