File bs_wizard of Package obs-wizard

#!/usr/bin/perl
#
# Copyright (c) 2008 Michal Marek, Novell Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################
# 
# Wizard Server
# accepts incoming inspects requests and runs wizard_inspect on each tarball
# sequentially

use strict;
use warnings;

BEGIN {
  my ($wd) = $0 =~ m-(.*)/- ;
  $wd ||= '.';
  unshift @INC,  "$wd";
}

use Data::Dumper;
use Digest::MD5 qw(md5_hex);
use Fcntl qw(:DEFAULT :flock);

use BSConfig;
use BSStdServer;
use XML::Structured;

my $port = 5753;

my $queue_dir = "$BSConfig::bsdir/wizard";

my $inspect_helper = "/usr/lib/obs/wizard_inspect";

my $result_dtd = [
  'result' =>
    [[ 'data' => 'name', '_content' ]]
];

my $wizard_dtd = [
  'wizard-inspect' =>
    [],
    'project',
    'package',
    'filename',
    'status',
    'details',
    $result_dtd
];

my $worker_pid;

sub lock_queue {
  open(QUEUE_LOCK, '>>', "LOCK");
  flock(QUEUE_LOCK, LOCK_EX) || die("Can't obtain queue lock");
  print STDERR "[$$] LOCK\n";
}

sub unlock_queue {
  flock(QUEUE_LOCK, LOCK_UN);
  close(QUEUE_LOCK);
  print STDERR "[$$] UNLOCK\n";
}

sub scan_queue {
  print STDERR "scan_queue...\n";
  my $dir = shift || ".";
  opendir(my $dh, $dir) or die "Can't open $queue_dir/$dir: $!\n";
  my @res = sort { (stat("$dir/$a"))[9] <=> (stat("$dir/$b"))[9] } grep (/^[0-9a-f]{32}$/,
    readdir($dh));
  closedir($dh);
  print STDERR "scan_queue => " . scalar(@res) . " entries\n";
  return @res;
}

## worker ##

sub inspect {
  my ($id, $xml) = @_;
  print STDERR "inspect: $id\n";
  my $tarball = "tmp/$xml->{filename}";
  my $c;
  my $param = {
   uri => "$BSConfig::srcserver/source/$xml->{project}/$xml->{package}/$xml->{filename}",
   timeout => 30,
   filename => $tarball,
   receiver => \&BSHTTP::file_receiver,
  };
  my $pipe;
  eval {
    $c = BSRPC::rpc($param);
    open($pipe, '-|', $inspect_helper, $tarball);
    my $res = XMLin($result_dtd, $pipe);
    close($pipe);
    undef $pipe;
    if ($? != 0) {
      die "helper exited with status @{[$? >> 8]}";
    }
    $xml->{result} = $res;
    $xml->{status} = 'done';
  };
  if ($@) {
    warn($@);
    $xml->{status} = 'error';
    $xml->{details} = $@;
    close($pipe) if $pipe;
    return;
  }
}

sub worker_loop {
  while (1) {
    my @q = scan_queue();
    if (@q == 0) {
      # quick & dirty hack: don't pause but sleep in case we missed a signal
      sleep(30);
      next;
    }
    # we don't hold the lock all the time, therefore id's might not exist
    # anymore (due to clients canceling them)
    lock_queue();
    foreach my $id (@q) {
      next if ! -e $id;
      my $xml = XMLinfile($wizard_dtd, $id);
      unlock_queue();
      inspect($id, $xml);
      lock_queue();
      next if ! -e $id;
      open(my $fh, '>', "done/$id") or die "Can't open $queue_dir/done/$id: $!\n";
      print $fh XMLout($wizard_dtd, $xml);
      close($fh);
      unlink($id)
    }
    unlock_queue();
  }
}

sub start_worker {
  $worker_pid = fork();
  die "Can't fork: $!\n" unless defined $worker_pid;
  if ($worker_pid) {
    print STDERR "worker pid: $worker_pid\n";
    return;
  }
  $SIG{USR1} = sub {};
  my $user = $BSConfig::bsuser;
  my $group = $BSConfig::bsgroup;
  !defined($user) || defined($user = (getpwnam($user))[2]) || die("unknown user\n");
  !defined($group) || defined($group = (getgrnam($group))[2]) || die("unknown group\n");
  ($(, $)) = ($group, $group);
  die "setgid: $!\n" if ($) != $group);
  ($<, $>) = ($user, $user);
  die "setuid: $!\n" if ($> != $user);
  worker_loop();
  exit;
}

## HTTP server ##

sub fileid {
  my ($cgi) = @_;
  return md5_hex("$cgi->{project}/$cgi->{package}/$cgi->{filename}");
}

sub find_id {
  my $id = shift;
  return $id if -e $id;
  return "done/$id" if -e "done/$id";
  return undef;
}


sub GET_hello {
  my ($cgi) = @_;
  return "<hello name=\"Wizard Server\" />\n";
}

sub GET_inspect {
  my ($cgi) = @_;
  my $id = fileid($cgi);
  my $reply;
  lock_queue();
  my $f = find_id($id);
  if (!defined $f) {
    $f = $id;
    $reply = XMLout($wizard_dtd, {
        project => $cgi->{project},
        package => $cgi->{package},
        filename => $cgi->{filename},
        status => 'pending'});
    open(my $fh, '>', $f) or die "Can't open $f";
    print $fh $reply;
    close($fh);
    if (!kill USR1 => $worker_pid) {
      unlink($f);
      die "Wizard worker not running\n";
    }
  } else {
    open(my $fh, '<', $f) or die "Can't open $f";
    my @l = <$fh>;
    close($fh);
    $reply = join("", @l);
  }
  unlock_queue();
  return $reply;
}

sub DELETE_inspect {
  my ($cgi) = @_;
  my $id = fileid($cgi);
  lock_queue();
  my $f = find_id($id);
  if (defined $f) {
    unlink($f) or die "Can't delete $id: $!\n";
    return $BSStdServer::return_ok;
  }
  die "No such request to delete\n";
}

sub GET_queue {
  return ({entry => [{name => "done"}, {name => "pending"}]}, $BSXML::dir);
}

sub GET_queue_pending {
  return ({entry => [ map({name => $_}, scan_queue()) ]}, $BSXML::dir);
}

sub GET_queue_done {
  return ({entry => [ map({name => $_}, scan_queue("done")) ]}, $BSXML::dir);
}

sub GET_ping_worker {
  kill USR1 => $worker_pid or die "Wizard worker not running\n";
  return $BSStdServer::return_ok;
}

my $dispatches = [
  '/' => \&GET_hello,
  '/inspect/$project/$package/$filename' => \&GET_inspect,
  'DELETE:/inspect/$project/$package/$filename' => \&DELETE_inspect,
  '/queue' => \&GET_queue,
  '/queue/pending' => \&GET_queue_pending,
  '/queue/done' => \&GET_queue_done,
  '/ping_worker' => \&GET_ping_worker,
];

my $conf = {
  'port' => $port,
  'dispatches' => $dispatches,
  'setkeepalive' => 1,
  'maxchild' => 20,
};

chdir($queue_dir) or die "Can't chdir to $queue_dir: $!\n";
start_worker();
BSStdServer::server('bs_wizard', \@ARGV, $conf);

# vim:ts=2:sw=2:et