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