#!/usr/bin/perl -w
#
# Copyright (c) 2008 Adrian Schroeter, 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
#
################################################################
#
# The Admin Tool
#

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

use POSIX;
use Data::Dumper;
use Getopt::Long;
use Storable ();
use XML::Structured ':bytes';

use Build;

use BSConfig;
use BSFileDB;
use BSWatcher;
use BSUtil;
use BSXML;
use BSKiwiXML;
use BSProductXML;

my $reporoot  = "$BSConfig::bsdir/build";
my $eventroot = "$BSConfig::bsdir/events";
my $projectsdir = "$BSConfig::bsdir/projects";
my $srcrepdir = "$BSConfig::bsdir/sources";

sub echo_help {
    print "\n
The openSUSE Build Service Admin Tool
=====================================

*** This tool is only intended to be used by experienced admins on
*** the backend server ! 

General options
===============

 --help
   Gives this help output.

Job Controlling
===============

 --shutdown-scheduler <architecture>
   Stops the scheduler nicely with dumping out its current state 
   for fast startup.

 --check-project <project> <architecture>
   Check status of a project and its repositories again

 --deep-check-project <project> <architecture>
   Check status of a project and its repositories again
   This deep check includes also the sources, in case of lost events.

 --check-package <project> <package> <architecture>
   Check status of a package in all repositories

 --clone-repository <source project> <source repositroy> <destination repositroy>
 --clone-repository <source project> <source repositroy> <destination project> <destination repositroy>
   Clone an existing repo into another existing repository.
   Usefull for creating snapshots.

 --rescan-repository <project> <repositroy> <architecture>
   Asks the scheduler to scan a repository for new packages and add
   them to the cache file.

Debug Options
=============

 --dump-cache <project> <repository> <architecture>
   Dumps out the content of a binary cache file.
   This shows all the content of a repository, including all provides
   and requires.

 --dump-state <architecture>

 --dump-relsync <file>
   To dump content of :relsync files.

 --set-relsync <file> <key> <value>
   Modify key content in a a :relsync file.

 --check-meta-xml <project>
 --check-meta-xml <project> <package>
   Is parsing a project or package xml file and puts out error messages, in case of errors.

 --check-product-xml <file>
   Is parsing a product xml file and puts out error messages, in case of errors.
   It does expand all xi:include references and validates the result.

 --check-product-group-xml <file>
   Is parsing a group xml file from a product definition and puts out error messages, in case of errors.
   
 --check-kiwi-xml <file>
 --check-kiwi-xml <project> <package>
   Is parsing a kiwi xml file and puts out error messages, in case of errors.

 --check-pattern-xml <file>
   Is parsing a pattern xml file and puts out error messages, in case of errors.

 --check-request-xml <file>
   Is parsing a request xml file and puts out error messages, in case of errors.

 --parse-build-desc <file>
   Parse a spec, dsc or kiwi file with the Build script parser.
";
}

#### FIXME: these functions are copied from src server. We should move it to some util class maybe.
my $srcrevlay = [qw{rev vrev srcmd5 version time user comment}];
sub getrev {
  my ($projid, $packid, $rev) = @_;
  die("bad projid\n") if $projid =~ /\// || $projid =~ /^\./;
  return {'srcmd5' => 'pattern', 'rev' => 'pattern'} if $packid eq '_pattern';
  die("bad packid\n") if $packid =~ /\// || $packid =~ /^\./;
  undef $rev if $rev && ($rev eq 'latest' || $rev eq 'build');
  undef $rev if $rev && $rev eq 'upload' && ! -e "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS";
  if (!defined($rev)) {
    $rev = BSFileDB::fdb_getlast("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay);
    $rev = {'srcmd5' => 'empty'} unless $rev;
  } elsif ($rev =~ /^[0-9a-f]{32}$/) {
    return undef unless -e "$projectsdir/$projid.pkg/$packid.rev";
    $rev = {'srcmd5' => $rev, 'rev' => $rev};
  } elsif ($rev eq 'upload') {
    $rev = {'srcmd5' => 'upload', 'rev' => 'upload'}
  } elsif ($rev eq 'repository') {
    $rev = {'srcmd5' => 'empty', 'rev' => 'repository'}
  } else {
    $rev = BSFileDB::fdb_getmatch("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay, 'rev', $rev);
  }
  $rev->{'srcmd5'} =~ s/\/.*// if $rev;         # XXX still needed?
  return $rev;
}
sub lsrep {
  my ($projid, $packid, $srcmd5) = @_;
  die("no such revision\n") unless defined $srcmd5;
  local *F;
  die("bad packid\n") if $packid =~ /\// || $packid =~ /^\./;
  if ($srcmd5 eq 'upload') {
    open(F, '<', "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS") || die("$packid/$srcmd5-$packid: not in repository\n");
  } elsif ($srcmd5 eq 'pattern') {
    open(F, '<', "$projectsdir/$projid.pkg/pattern-MD5SUMS") || return {};
  } elsif ($srcmd5 eq 'empty') {
    return {};
  } else {
    die("bad srcmd5 '$srcmd5'\n") if $srcmd5 !~ /^[0-9a-f]{32}$/;
    if (!open(F, '<', "$srcrepdir/$packid/$srcmd5-MD5SUMS")) {
      return {'_linkerror' => $srcmd5} if -e "$srcrepdir/$packid/$srcmd5-_linkerror";
      die("$packid/$srcmd5-$packid: not in repository\n");
    }
  }
  my @files = <F>;
  close F;
  chomp @files;
  return {map {substr($_, 34) => substr($_, 0, 32)} @files};
}

sub findfile {
  my ($projid, $packid, $repoid, $ext, $files) = @_;
  $files = lsrep($projid, $packid, $files) unless ref $files;
  return ($files->{"$packid-$repoid.$ext"}, "$packid-$repoid.$ext") if defined($repoid) && $files->{"$packid-$repoid.$ext"};
  return ($files->{"$packid.$ext"}, "$packid.$ext") if $files->{"$packid.$ext"} && defined($repoid);
  my @files = grep {/\.$ext$/} keys %$files;
  @files = grep {/^\Q$packid\E/i} @files if @files > 1;
  return ($files->{$files[0]}, $files[0]) if @files == 1;
  if (@files > 1) {
    if (!defined($repoid)) {
      # return (undef, undef);
      @files = sort @files;
      return ($files->{$files[0]}, $files[0]);
    }
    @files = grep {/^\Q$packid-$repoid\E/i} @files if @files > 1;
    return ($files->{$files[0]}, $files[0]) if @files == 1;
  }
  return (undef, undef);
}
#### end of copy from src server

sub find_latest_file {
  my ($project, $package, $type) = @_;

  my $rev = getrev($project, $package);
  if (!$rev || $rev->{'srcmd5'} eq 'empty') {
    return ( "Refered to non existing $type in $project $package" );
  }
  my $files = lsrep($project, $package, $rev->{'srcmd5'});
# FIXME: handle source links
#   $files = handlelinks($projid, $pinfo, $files, $rev) if ref($files) && $files->{'_link'};
  if (!ref $files) {
    return( "could not get file list for $project $package" );
  }
  my ($md5, $file) = findfile($project, $package, undef, $type, $files);
  return ($md5, $file);
}

sub dump_nStore {
  my ($file) = @_;
  my $cache = Storable::retrieve($file) || {};
  print Dumper($cache);
  return $cache
}

sub dump_cache {
  my ($project, $repo, $arch) = @_;
  dump_nStore("$reporoot/$project/$repo/$arch/:full.cache");
}

sub clone_repository {
  my ($srcproject, $srcrepo, $destproject, $destrepo) = @_;
  my $srcdir  = $reporoot."/".$srcproject."/".$srcrepo;
  my $destdir = $reporoot."/".$destproject."/".$destrepo;
  my $tmpdir  = $BSConfig::tmpdir || "$BSConfig::bsdir/tmp";

  die ( "Destination repo must get created by scheduler first !" ) unless -d $destdir;

  mkdir_p($tmpdir) || die("mkdir_p $tmpdir: $!\n");
  $tmpdir .= "/bs_admin.$$";
  if (-d $tmpdir) {
    system('rm', '-rf', $tmpdir) && die("removing of $tmpdir failed!\n");
  }
  if (-d "$tmpdir.old") {
    system('rm', '-rf', "$tmpdir.old") && die("removing of $tmpdir.old failed!\n");
  }

  print "cloning $srcproject / $srcrepo\n";
  system('cp', '-al', $srcdir, $tmpdir) && die( "cloning failed !" );

  # remove jobhistory files
  for my $a (ls($tmpdir)) {
    unlink("$tmpdir/$a/:jobhistory");
  }

  print "exchanging with $destproject / $destrepo\n";
  rename($destdir, "$tmpdir.old") || die("rename $destdir $tmpdir.old: $!\n");
  rename($tmpdir, $destdir) || die("rename $tmpdir $destdir: $!\n");

  print "tell schedulers about the change ";
  opendir(DIR, $destdir) || die "can't opendir $destdir: $!";
  my @archs = grep { ! /^\./ && -d "$destdir/$_" } readdir(DIR);
  closedir DIR;
  for my $a ( @archs ) {
    print $a.", ";
    write_event( $destproject, $destrepo, $a, 'project' );
  }

  print "\nremoving old tree in $tmpdir.old\n";
  system('rm', '-rf', "$tmpdir.old") && die("removing of $tmpdir.old failed!\n");

  print "finished.\n";
}

sub check_xml_file {
  my ($file, $type) = @_;

  print "parsing $file\n";
  my $xmldesc = readxml("$file", $type, 0);
  if ( defined($xmldesc) ) {
    print "Succesfull parsed file !\n";
  } else {
    die("ERROR: Unable to parse xml file !\n");
  }
}

sub check_product_xml_file {
  my ($file) = @_;

  print "parsing $file\n";
  my $xmldesc = BSProductXML::readproductxml("$file", 0, 1 );
  if ( defined($xmldesc) ) {
    print "Succesfull parsed file !\n";
  } else {
    die("ERROR: Unable to parse xml file !\n");
  }
}


sub check_kiwi_xml {
  my ($project, $package) = @_;

  my ($md5, $file) = find_latest_file($project, $package, 'kiwi');
  if (defined($md5) && defined($file)) {
    my $f = "$srcrepdir/$package/$md5-$file";
    check_xml_file($f, $BSKiwiXML::kiwidesc);
  } else {
    die("ERROR: No kiwi config file found in $project / $package !\n");
  }
}

sub check_meta_xml {
  my ($project, $package) = @_;
  my $file;

  if (defined($package)){
    $file = "$projectsdir/${project}.pkg/${package}.xml";
    $metadesc = readxml("$file", $BSXML::pack, 0);
  } else {
    $file = "$projectsdir/$project.xml";
    $metadesc = readxml("$file", $BSXML::proj, 0);
  }

  if (defined($metadesc)) {
    print "Succesfull parsed $file !\n";
  } else {
    die("ERROR: Unable to parse Meta XML in $file !\n");
  }
}

sub write_event {
  my ($project, $repo, $arch, $event, $package) = @_;
  my $evname = "${event}::$project";
  $evname .= "::$package" if defined $package;
  $evname .= "::$repo" if defined $repo;
  my $ev = { 'type' => $event };
  $ev->{'project'} = $project if defined $project;
  $ev->{'package'} = $package if defined $package;
  $ev->{'repository'} = $repo if defined $repo;
  writexml("$eventroot/$arch/.$evname$$", "$eventroot/$arch/$evname", $ev, $BSXML::event);
  local *F;
  if (sysopen(F, "$eventroot/$arch/.ping", POSIX::O_WRONLY|POSIX::O_NONBLOCK)) {
    syswrite(F, 'x');
    close(F);
  }
}

sub scan_repo {
  my ($project, $repo, $arch) = @_;
  write_event( $project, $repo, $arch, 'scanrepo' );
}

sub dump_state {
  my ($arch) = @_;
  write_event( undef, undef, $arch, 'dumpstate' );
}

sub shutdown_scheduler {
  my ($arch) = @_;
  write_event( '', undef, $arch, 'exitcomplete' );
}

sub check_project {
  my ($project, $arch, $deep) = @_;
  if (defined $deep) {
    write_event($project, undef, $arch, 'package');
  } else {
    write_event($project, undef, $arch, 'recheck');
  }
}

sub check_package {
  my ($project, $package, $arch) = @_;
  write_event($project, undef, $arch, 'package', $package);
}

#
# Argument parsing
#
if ( @ARGV < 1 ){
  echo_help();
  exit(1);
}

while (@ARGV) {
  my $arg = shift @ARGV;
  if ($arg eq "--help") {
    echo_help();
    exit(0);
  }
  if ($arg eq "--check-meta-xml") {
    die("ERROR: need at least a project name as argument!\n") if @ARGV < 1;
    my $project = shift @ARGV;
    if (@ARGV == 1) {
      my $package = shift @ARGV;
      check_meta_xml($project, $package);
    } else {
      check_meta_xml($project);
    }
  } elsif ($arg eq "--check-product-group-xml") {
    die("ERROR: need a file name as argument!\n") if @ARGV != 1;
    my $file = shift @ARGV;
    check_xml_file($file, $BSProductXML::group);
  } elsif ($arg eq "--check-product-xml") {
    die("ERROR: need a file name as argument!\n") if @ARGV != 1;
    my $file = shift @ARGV;
    check_product_xml_file($file);
  } elsif ($arg eq "--check-pattern-xml") {
    die("ERROR: need a file name as argument!\n") if @ARGV != 1;
    my $file = shift @ARGV;
    check_xml_file($file, $BSXML::pattern);
  } elsif ($arg eq "--check-request-xml") {
    die("ERROR: need a file name !\n") if @ARGV != 1;
    my $file = shift @ARGV;
    check_xml_file($file, $BSXML::request);
  } elsif ($arg eq "--check-kiwi-xml") {
    die("ERROR: need either file name or project and package as argument!\n") if @ARGV < 1;
    if (@ARGV == 1){
      my $file = shift @ARGV;
      check_xml_file($file, $BSKiwiXML::kiwidesc);
    } else {
      my $project = shift @ARGV;
      my $package = shift @ARGV;
      check_kiwi_xml($project, $package);
    }
  } elsif ($arg eq "--parse-build-desc") {
    die("ERROR: need a file name as argument (spec, dsc or kiwi)!\n") if @ARGV != 1;
    my $ret = Build::parse(undef, shift @ARGV);
    print Dumper($ret);
  } elsif ($arg eq "--dump-cache") {
    if (@ARGV == 1) {
      dump_nStore(shift @ARGV);
    } else {
      die("ERROR: need project, repository and architecture as argument!\n") if @ARGV < 3;
      my $project = shift @ARGV;
      my $repo = shift @ARGV;
      my $arch = shift @ARGV;
      dump_cache($project, $repo, $arch);
    }
  } elsif ($arg eq "--dump-relsync" || $arg eq "--set-relsync") {
    die("ERROR: need file as argument!\n") if @ARGV < 1;
    my $file = shift @ARGV;
    my $s = dump_nStore($file);
    my $key = shift @ARGV;
    my $value = shift @ARGV;
    if ( defined($key) && defined($value) ){
      $s->{$key} = $value;
      print "\nChanged to:\n";
      print Dumper($s);
      Storable::nstore($s, $file);
    };
  } elsif ($arg eq "--dump-state") {
    die("ERROR: need architecture as argument!\n") if @ARGV < 1;
    my $arch = shift @ARGV;
    dump_state( $arch );
  } elsif ($arg eq "--shutdown-scheduler") {
    die("ERROR: need architecture as argument!\n") if @ARGV < 1;
    my $arch = shift @ARGV;
    shutdown_scheduler( $arch );
  } elsif ( $arg eq "--check-project" ) {
    die("ERROR: need project and architecture as argument!\n") if @ARGV < 2;
    my $project = shift @ARGV;
    my $arch = shift @ARGV;
    check_project($project, $arch);
  } elsif ( $arg eq "--check-package" ) {
    die("ERROR: need project, package and architecture as argument!\n") if @ARGV < 3;
    my $project = shift @ARGV;
    my $package = shift @ARGV;
    my $arch = shift @ARGV;
    check_package($project, $package, $arch);
  } elsif ( $arg eq "--deep-check-project" ) {
    die("ERROR: need project and architecture as argument!\n") if @ARGV < 2;
    my $project = shift @ARGV;
    my $arch = shift @ARGV;
    check_project($project, $arch, 1);
  } elsif ( $arg eq "--clone-repository" ) {
    die("ERROR: need source project & repository and destination project & repository as argument!\n") if @ARGV < 3;
    my $srcproject = shift @ARGV;
    my $srcrepo = shift @ARGV;
    my $destproject;
    my $destrepo;
    if (@ARGV == 1) {
       $destrepo = shift @ARGV;
       $destproject = $srcproject;
    } else {
       $destproject = shift @ARGV;
       $destrepo = shift @ARGV;
    }
    clone_repository($srcproject, $srcrepo, $destproject, $destrepo);
  } elsif ($arg eq "--rescan-repository") {
    die("ERROR: need project, repository and architecture as argument!\n") if @ARGV < 3;
    my $project = shift @ARGV;
    my $repo = shift @ARGV;
    my $arch = shift @ARGV;
#    drop_cache( $project, $repo, $arch );
    scan_repo( $project, $repo, $arch );
  } else {
    echo_help();
    exit(1)
  }
}

