obs-server 2.7.1-10 / usr / lib / obs / server / bs_service

#!/usr/bin/perl -w
#
# Copyright (c) 2009 Adrian Schroeter, Novell Inc.
# Copyright (c) 2006-2009 Michael Schroeder, 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
#
################################################################
#
# Source service process. Processes package and project _service
# files.
#

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

use Digest::MD5 ();
use XML::Structured ':bytes';
use Data::Dumper;
use POSIX;
use Fcntl qw(:DEFAULT :flock);

use BSRPC;
use BSServer;
use BSStdServer;
use BSConfiguration;
use BSUtil;
use BSXML;
use BSHTTP;
use BSBuild;

use strict;

$BSConfig::bsuser = $BSConfig::bsserviceuser;
$BSConfig::bsgroup = $BSConfig::bsservicegroup;

BSUtil::set_fdatasync_before_rename() unless $BSConfig::disable_data_sync || $BSConfig::disable_data_sync;

my $tempdir = $BSConfig::servicetempdir || $BSConfig::servicetempdir || "$BSConfig::bsdir/service";
my $port = 5152;
$port = $1 if $BSConfig::serviceserver =~ /:(\d+)$/;

my $servicedir = $BSConfig::servicedir || "/usr/lib/obs/service";
my $rootservicedir = $BSConfig::serviceroot ? "$BSConfig::serviceroot/$servicedir" : $servicedir;

my $noproxy = $BSConfig::noproxy;
my $maxchild = $BSConfig::service_maxchild;

sub usage {
  my ($ret) = @_;

print <<EOF;
Usage: $0 [OPTION]

       --port      : Port to listen for connections

       --help      : this message

EOF
  exit($ret || 0);
}

my @argv = @ARGV;	# need to make copy for restart feature
while (@argv) {
  usage(0) if $argv[0] eq '--help';
  exit 0 if $argv[0] eq '--test'; # just for self-startup test
  if ($argv[0] eq '--port') {
    shift @argv;
    $port = shift @argv;
    next;
  }
  last;
}

sub rm_rf {
  my ($dir) = @_;
  unlink($dir);		# just in case this is a symlink
  BSUtil::cleandir($dir);
  rmdir($dir);
}

sub run_source_update {
  my ($cgi, $projid, $packid) = @_;

  # chdir into a clean temp directory
  my $myworkdir = "$tempdir/$$";
  rm_rf($myworkdir);
  die("cannot get rid of old work dir\n") if -e $myworkdir;
  mkdir_p($myworkdir);
  die("$myworkdir not writable for me") unless -w $myworkdir;
  mkdir("$myworkdir/src") || die("mkdir $myworkdir/src: $!\n");
  chdir("$myworkdir/src") || die("chdir $myworkdir/src: $!\n");

  # unpack source data
  my $uploaded = BSServer::read_cpio("$myworkdir/src");

  die("no _service file in sources!\n") unless -e "_service" || -e "_serviceproject";

  # move all files from former service run to '.old'
  # so that they're available for services
  mkdir_p('.old');
  for my $file (grep {/^_service[:_]/} ls('.')) {
    print "moving old file $file to .old\n";
    rename($file, ".old/$file");
  }

  # set environment
  $::ENV{'OBS_SERVICE_PROJECT'} = $projid;
  $::ENV{'OBS_SERVICE_PACKAGE'} = $packid;
  $::ENV{'no_proxy'} = $noproxy;

  # run all services
  my $error;
  for my $sf ('_service', '_serviceproject') {
    next unless -e $sf;
    my $infoxml = readstr($sf);
    my $serviceinfo = XMLin($BSXML::services, $infoxml);
    for my $service (@{$serviceinfo->{'service'}}) {
      my $name = $service->{'name'};
      BSVerify::verify_filename($name);
      if (defined($service->{'mode'}) && ($service->{'mode'} eq 'localonly' || $service->{'mode'} eq 'disabled' || $service->{'mode'} eq 'buildtime')) {
        print "Skip $name\n";
        next;
      }
      print "Run for $name\n";
      my $servicedef = readxml("$rootservicedir/$name.service", $BSXML::servicetype);
      my @run;
      if (defined $BSConfig::service_wrapper->{$name} ) {
        push @run, $BSConfig::service_wrapper->{$name};
      } elsif (defined $BSConfig::service_wrapper->{'*'}) {
        push @run, $BSConfig::service_wrapper->{'*'};
      }
      push @run, "$servicedir/$name";
      for my $param (@{$service->{'param'}}) {
        next if $param->{'name'} eq 'outdir';
        next unless $param->{'_content'};
        die("$name: service parameter \"$param->{'name'}\" is not defined\n") unless grep {$_->{'name'} eq $param->{'name'}} @{$servicedef->{'parameter'}};
        push @run, "--$param->{'name'}";
        push @run, $param->{'_content'};
      }
      push @run, "--outdir";
      push @run, "$myworkdir/out";

      mkdir("$myworkdir/out") || die("mkdir $myworkdir/out: $!\n");
    
      # call the service
      if (! open(SERVICE, '-|')) {
        open(STDERR, ">&STDOUT");
        exec(@run);
        die("$run[0]: $!\n");
      }
    
      # collect output
      my $output = '';
      while (<SERVICE>) {
        $output .= $_;
      }
    
      if (close SERVICE) {
        # SUCCESS, move files inside and add prefix
        for my $file (grep {!/^[:\.]/} ls("$myworkdir/out")) {
	  next if -l "$myworkdir/out/$file" || ! -f _;	# only plain files for now
	  my $tfile = $file;
	  $tfile =~ s/^_service://s;
	  $tfile = "_service:$name:$tfile";
	  rename("$myworkdir/out/$file", $tfile) || die("rename $myworkdir/out/$file $tfile: $!\n");
        }
      } else { 
        # FAILURE, Create error file
	$output =~ s/[\r\n\s]+$//s;
        BSUtil::cleandir('.');
	BSUtil::writestr('_service_error', undef, "service $name failed:\n$output\n");
	$error = 1;
      }

      # delete no longer needed outdir
      rm_rf("$myworkdir/out");

      last if $error;
    }
    last if $error;
  }

  # remove old files (from former service run)
  rm_rf('.old');

  # get all generate files
  my @send = map {{'name' => $_, 'filename' => "$_"}} grep {/^_service[_:]/} ls('.');

  # check for non files (symlinks or directories)
  for my $file (@send) {
    die("Service result contains unreadable file '$file->{'filename'}'\n") unless -f $file->{'filename'};
  }

  # send everything back for real
  BSServer::reply_cpio(\@send);
  
  # clean up
  rm_rf($myworkdir);

  return undef;	# already replied
}

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

sub list_service {
  my ($cgi) = @_;
  my @sl;
  for my $servicefile (grep {/\.service$/} ls($rootservicedir)) {
     my $service = readxml("$rootservicedir/$servicefile", $BSXML::servicetype, 1);
     next unless $service && $service->{'name'};
     next unless -x "$rootservicedir/$service->{'name'}";
     push @sl, $service;
  }
  return ({'service' => \@sl}, $BSXML::servicelist); 
}

BSUtil::mkdir_p_chown($tempdir, $BSConfig::bsuser, $BSConfig::bsgroup);

# define server
my $dispatches = [
  '/' => \&hello,

  '!rw :' => undef,
  '!- GET:' => undef,
  '!- HEAD:' => undef,

  '/service' => \&list_service,
  '!- POST:/sourceupdate/$project/$package' => \&run_source_update,
];

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

BSStdServer::server('bs_service', \@ARGV, $conf);