#!/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
#

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

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

 --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>

 --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.

";
};

#### 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 );
};

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

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{
    print "ERROR: Unable to parse xml file !\n";
    die;
  };
};

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{
    print "ERROR: Unable to parse xml file !\n";
    die;
  };
};


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

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

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{
    print "ERROR: Unable to parse Meta XML in $file !\n";
    die;
  };
};

sub write_event {
  my ($project, $repo, $arch, $event) = @_;
  my $evname = "${event}::$project";
  $evname .= "::$repo" if defined $repo;
  my $ev = { "type" => $event };
  $ev->{ 'project' } = $project if defined $project;
  $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, undef, $arch, 'exit' );
};

sub check_project {
  my ($project, $arch) = @_;
  write_event( $project, undef, $arch, 'recheck' );
  #write_event( $project, undef, $arch, 'project' );
};

#
# 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-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 "--dump-cache") {
    if ( @ARGV eq 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") {
    die("ERROR: need file as argument!\n") if @ARGV < 1;
    my $file = shift @ARGV;
    dump_nStore($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 "--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)
  }
}

