WebSVN – DevTools – /dpkg_blat/trunk/src/blat/blatDaemon.pl

#! /usr/bin/perl
########################################################################
# Copyright (C) 2011 Vix-ERG Limited, All rights reserved
#
# Module name   : blatDaemon.pl
# Module type   :
# Compiler(s)   : Perl
# Environment(s):
#
# Description   :
#
# Usage         :   ARGV[0] - Path to config file for this instance
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use Data::Dumper;
use File::Spec::Functions;
use POSIX ":sys_wait_h";
use File::Temp qw/tempfile/;

use FindBin;                                    # Determine the current directory
use lib "$FindBin::Bin/lib";                    # Allow local libraries

use Utils;
use StdLogger;                                  # Log to sdtout
use Logger;                                     # Log to file

#
#   Database interface
#   Pinched from jats and modified so that this software is not dependent on JATS
#
use IO::Handle;
use JatsRmApi;
use DBI;

#
#   Globals
#
my $logger = StdLogger->new();                  # Stdout logger. Only during config
my $name = basename( $ARGV[0]);
   $name =~ s~.conf$~~;
my $now = 0;
my $tagDirTime = 0;
my $lastDirScan = 0;
my $lastReleaseScan = 0;
my $releaseScanMode = 0;
my $lastTagListScan = 0;
my $transferred;
my $mtimeConfig = 0;
my $conf;
my $extraPkgs;
my $excludePkgs;
my %releaseData;

#
#   Describe config uration parameters
#
my %cdata = (
    '.ignore'         => {'pkg\.(.+)' => 'pkgs' },
    'piddir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
    'sleep'           => {'default'   => 5      , 'fmt' => 'period'},
    'dpkg_archive'    => {'mandatory' => 1      , 'fmt' => 'dir'},
    'logfile'         => {'mandatory' => 1      , 'fmt' => 'vfile'},
    'logfile.size'    => {'default'   => '1M'   , 'fmt' => 'size'},
    'logfile.count'   => {'default'   => 9      , 'fmt' => 'int'},
    'verbose'         => {'default'   => 0      , 'fmt' => 'int'},
    'user'            => {'mandatory' => 1      , 'fmt' => 'text'},
    'hostname'        => {'mandatory' => 1      , 'fmt' => 'text'},
    'identity'        => {'mandatory' => 1      , 'fmt' => 'file'},
    'bindir'          => {'mandatory' => 1      , 'fmt' => 'text'},
    'tagdir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
    'forcedirscan'    => {'default'   => 100    , 'fmt' => 'period'},
    'tagage'          => {'default'   => '10m'  , 'fmt' => 'period'},
    'tagListUpdate'   => {'default'   => '1h'   , 'fmt' => 'period'},
    'synctime'        => {'default'   => '2h'   , 'fmt' => 'period'},
    'syncretry'       => {'default'   => '5m'   , 'fmt' => 'period'},
    'allProjects'     => {'default'   => 0      , 'fmt' => 'bool'},
    'project'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
    'release'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
    'writewindow'     => {'default'   => '3h'   , 'fmt' => 'period'},
    'maxpackages'     => {'default'   => 5      , 'fmt' => 'int'},
    'deletePackages'  => {'default'   => 0      , 'fmt' => 'bool'},
    'deleteImmediate' => {'default'   => 0      , 'fmt' => 'bool'},
    'deleteAge'       => {'default'   => 0      , 'fmt' => 'period'},
    'packageFilter'   => {'default'   => undef  , 'fmt' => 'text'},
    'active'          => {'default'   => 1      , 'fmt' => 'bool'},
);


#
#   Read in the configuration
#       Set up a logger
#       Write a pidfile - thats not used
readConfig();
Utils::writepid($conf);
$logger->logmsg("Starting...");
sighandlers($conf);

#
#   Main processing loop
#   Will exit when terminated by parent
#
while ( 1 )
{
    $logger->verbose3("Processing");
    $now = time();

    $transferred = {};
    readConfig();
    if ( $conf->{'active'} )
    {
        processReleaseList();
        processTags();
        maintainTagList();
    }
    %releaseData = ();

    sleep( $conf->{'sleep'} );

    #
    #   Reap any and all dead children
    #
    my $kid;
    do {
        $kid = waitpid(-1, WNOHANG);
    } while ( $kid > 0 );
}
$logger->logmsg("Child End");
exit 0;

#-------------------------------------------------------------------------------
# Function        : readConfig
#
# Description     : Re read the config file if it modification time has changed
#
# Inputs          : Nothing
#
# Returns         : 0       - Config not read
#                   1       - Config read
#                             Config file has changed
#
sub readConfig
{
    my ($mtime) = Utils::mtime($ARGV[0]);
    my $rv = 0;

    if ( $mtimeConfig != $mtime )
    {
        $logger->logmsg("Reading config file: $ARGV[0]");
        $mtimeConfig = $mtime;
        my $errors;
        ($conf, $errors) = Utils::readconf ( $ARGV[0], \%cdata );
        if ( scalar @{$errors} > 0 )
        {
            warn "$_\n" foreach (@{$errors});
            die ("Config contained errors\n");
        }

        #
        #   Reset some information
        #   Create a new logger
        #
        $logger = Logger->new($conf);
        $conf->{logger} = $logger;
        $conf->{'pidfile'} = $conf->{'piddir'} . '/' . $name . '.pid';
        $logger->verbose("Log Levl: $conf->{verbose}");

        #
        #   Extract extra package config
        #
        $extraPkgs = {};
        $excludePkgs = {};
        while (my($key, $data) = each ( %{$conf->{pkgs}} ))
        {
            if ( $data eq 'EXCLUDE' )
            {
                $excludePkgs->{$key} = 1;
                $logger->verbose("Exclude Pkg: $key");
            }
            else
            {
                $extraPkgs->{$key}{$data} = 1;
                $logger->verbose("Extra Pkg: $key -> $data");
            }
        }

        $logger->verbose("Filter Packages: " . $conf->{'packageFilter'})
            if ( defined $conf->{'packageFilter'} );

        $logger->warn("Transfer session configured as not active")
            unless ( $conf->{'active'} );

        $logger->warn("Transfer all projects packages")
            if ( $conf->{'allProjects'} );

        #
        #   When config is read force some actions
        #       - Force tagList to be created
        #       - Force release scan
        $lastTagListScan = 0;
        $lastReleaseScan = 0;
        $rv = 1;
    }
    return $rv;
}


#-------------------------------------------------------------------------------
# Function        : processReleaseList
#
# Description     : Process the release list
#                       Determine if its time to process release list
#                       Determine release list
#                       Determine release content
#                       Determine new items
#
# Inputs          : None
#
# Returns         : Nothing
#
sub processReleaseList
{
    #
    #   Is Release List Processing active
    #   Can configure blat to disable release sync
    #   This will then allow 'new' packages to be sent
    #
    if ( $conf->{maxpackages} == 0 || $conf->{'synctime'} <= 0)
    {
        $logger->verbose2("processReleaseList disabled");
        return;
    }

    #
    #   Time to perform the scan
    #   Will do at startup and every time period there after
    #
    my $wtime = $releaseScanMode ? $conf->{'syncretry'} : $conf->{'synctime'};
    return unless ( $now > ($lastReleaseScan + $wtime ));
    $logger->verbose("processReleaseList");
    $lastReleaseScan = $now;
    $releaseScanMode = 1;                                   # Assume error

    #
    #   Get list of packages from Remote site
    #   Invoke a program on the remote site and parse the results
    #
    #     ssh  -i ./ssh/id_rsa_pkg_admin  pkg_admin@10.247.28.57 "./get_plist.pl"
    #
    #   Returned data looks like:
    #   1141792602 GMT(Wed Mar  8 04:36:42 2006) [DL] ishieldmodules/11.5.0.cots
    #   
    #
    my $remotePkgList;
    my $ph;
    my $tgt_cmd = "$conf->{'bindir'}/get_plist.pl";
    my $ssh_cmd = "ssh -n -o \"BatchMode yes\" -i $conf->{'identity'} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";

    $logger->verbose2("processReleaseList:ssh_cmd:$ssh_cmd");
    open ($ph, "$ssh_cmd |");
    while ( <$ph> )
    {
        chomp;
        if ( parsePkgList($_, \%{$remotePkgList} ) )
        {
            $logger->verbose2("processReleaseList:Data: $_");
        }
        else
        {
            $logger->warn("processReleaseList:Bad Data: $_");
        }
    }
    close ($ph);
    $logger->verbose("processReleaseList:End: $?");
    if ( $? != 0 )
    {
        $logger->warn("Cannot retrieve package list: $?");
        return;
    }
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
    

    #
    #   Determine the set of packages in the releases to be transferred
    #   Examine
    #
    my @rlist = getReleaseList();
    unless ( @rlist )
    {
        $logger->verbose2("No Releases to Process");
        return;
    }
    my $pkgList = getPkgList(@rlist);

    #
    #   Append extra packages
    #   These are packages that are specifically named by the user
    #
    #   Note: If there are symbolic links, then the target of the
    #         link is treated used as the package name
    #
    #         Symlink MUST be within the same directory
    #
    #         Used to transfer jats2_current
    #
    my $pkgLink;
    while ( (my ($pname, $pvers)) = each %{$extraPkgs} ) {
        while ( (my ($pver, $pdata) ) = each %{$pvers} ) {

            my $epath = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
            if ( -l $epath )
            {
                my $lver = readlink( $epath );
                if ( ! defined $lver )
                {
                    $logger->warn("Cant resolve symlink: $pname, $pver");
                    next;
                }

                if ( $lver =~ m ~/~ )
                {
                    $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
                    next;
                }
                $pkgLink->{$pname}{$pver} = $lver;
                $pdata = $pver;
                $pver = $lver;
            }

            $logger->verbose2("Add extra package: $pname, $pver, $pdata");
            $pkgList->{$pname}{$pver} = $pdata;
        }
    }

    #
    #   If there are no packages to process, then assume that this is an error
    #   condition. Retry the operation soon.
    #
    unless ( keys %{$pkgList} )
    {

        $logger->verbose2("No packages to process");
        return;
    }

#    while ( (my ($pname, $pvers)) = each %{$pkgList} )
#    {
#        while ( (my ($pver, $ptime) ) = each %{$pvers} )
#        {
#            print "L-- $pname, $pver, $ptime \n";
#
#        }
#    }

    #
    #   Delete Excess Packages
    #       Packages not required on the target
    #           KLUDGE: Don't delete links to packages
    #           Don't delete packages marked for deletion
    #
    my $excessPkgList;
    my $excessPkgListCount = 0;
    if ( $conf->{deletePackages} )
    {
        while ( (my ($pname, $pvers)) = each %{$remotePkgList} )
        {
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
            {
                if ( !exists $pkgList->{$pname}{$pver} )
                {
                    if ( exists $pkgLink->{$pname}{$pver} )
                    {
                        $logger->verbose2("Keep Excess package-link: ${pname}/${pver}");
                        next;
                    }

                    if ( exists $excludePkgs->{$pname} )
                    {
                        $logger->verbose2("Keep Excluded package: ${pname}");
                        next;
                    }

                    if ( exists $pdata->{deleted} )
                    {
                        if ( $conf->{deleteAge} )
                        {
                            if ( $pdata->{deleted} <= $conf->{deleteAge} )
                            {
                                $logger->verbose2("Already marked for future age deletion: ${pname}/${pver}, $pdata->{deleted}");
                                next;
                            }
                            $pdata->{FORCEDELETE} = 1;
                        }

                        if ( !$conf->{deleteImmediate} )
                        {
                            $logger->verbose2("Already marked for deletion: ${pname}/${pver}");
                            next;
                        }
                    }

                    #
                    #   Force deletion
                    #       deleteImmediate mode
                    #       target is a broken link
                    #
                    $pdata->{FORCEDELETE} = 1
                        if ($conf->{deleteImmediate} || $pdata->{broken});

                    $excessPkgList->{$pname}{$pver} = $pdata;
                    $excessPkgListCount++;
                    $logger->verbose("Excess package: ${pname}/${pver}");
                }
#                else
#                {
#                        $logger->verbose3("Retain package: ${pname}/${pver}");
#                }
            }
        }
    }

    #
    #   Process the remote list and the local list
    #   The remote time-stamp is the modification time of the packages descpkg file
    #
    #   Mark for transfer packages that
    #       Are in the local set but not the remote set
    #       Have a different time stamp
    #
    #   Ignore packages not in the local archive
    #   Ignore packages that don't have a descpkg
    #   Ignore packages that are writable - still being formed
    #
    my $needPkgList;
    my $needPkgListCount = 0;
    my $filteredCount = 0;
    my $missingCount = 0;
    my $writableCount = 0;
    my $excludeCount = 0;
    while ( (my ($pname, $pvers)) = each %{$pkgList} )
    {
        #
        #   Ignore excluded packages
        #
        if ( exists $excludePkgs->{$pname} )
        {
            $excludeCount++;
            next;
        }

        #
        #   Ignore packages that are filtered out
        #
        if ( defined $conf->{'packageFilter'} )
        {
            unless ( $pname =~ m~$conf->{'packageFilter'}~ )
            {
                $logger->verbose3("Filtering out: ${pname}");
                $filteredCount++;
                next;
            }
        }

        while ( (my ($pver, $pdata) ) = each %{$pvers} )
        {
            my $tmtime = $remotePkgList->{$pname}{$pver}{time} || 0;

            # Package is present in both list
            my ($mtime, $mode) = Utils::mtime( catfile( $conf->{'dpkg_archive'} , $pname, $pver, 'descpkg' ));
            if ( $mtime == 0 )
            {
                # PackageVersion not in local archive (at least the descpkg file is not)
                # Skip now - will pick it up later
                $logger->verbose("Package not in dpkg_archive: $pname, $pver");
                $missingCount++;
                next;
            }

            if ( $mode & 0222 )
            {
                # Descpkg file is writable
                # Package may be in the process of being created
                # If the package has been writable for a long time, then
                # consider for transfer
                my $age = $now - $mtime;
                if ( $age < ($conf->{'writewindow '} || 600) )
                {
                    $logger->verbose("Package is writable: $pname, $pver, ", $now - $mtime);
                    $writableCount++;
                    next;
                }
            }

            if ( $mtime != $tmtime )
            {
                # Package not present on target, or timestamps differ
                $logger->verbose("Package Needs to be transferred: $pname, $pver, $mtime, $tmtime");
                $needPkgList->{$pname}{$pver} = $pdata;
                $needPkgListCount++;
                next;
            }
        }
    }


    #
    #   Debug output only
    #   Display what we need to transfer
    #
    if ( $conf->{verbose} > 2 )
    {
        while ( (my ($pname, $pvers)) = each %{$needPkgList} )
        {
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
            {
                $logger->verbose("Need to transfer: $pname, $pver, $pdata");
            }
        }
    }
    if ( $conf->{verbose}  )
    {
        $logger->verbose("Packages to transfer: $needPkgListCount");
        $logger->verbose("Packages to delete: $excessPkgListCount");
        $logger->verbose("Packages filtered out: $filteredCount");
        $logger->verbose("Packages missing: $missingCount");
        $logger->verbose("Packages still writable: $writableCount");
        $logger->verbose("Packages excluded: $excludeCount");
    }

    #
    #   Time to do the real work
    #   Transfer packages and delete excess packages
    #   Note: Perform the transfers first
    #         Limit the number of packages processed in one pass
    #
    my $txcount = $conf->{maxpackages};

    #
    #   Transfer packages that we have identified
    #
    send_pkgs:
    while ( (my ($pname, $pvers)) = each %{$needPkgList} )
    {
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
        {
            if ( --$txcount <= 0 )
            {
                $logger->warn("Max transfer count exceeded: $needPkgListCount transfer remaining");
                $lastReleaseScan = 0;
                last send_pkgs;
            }

            if ( readConfig() )
            {
                $logger->warn("Config file changed");
                $lastReleaseScan = 0;
                $txcount = 0;
                last send_pkgs;
            }

            transferPackage ($pname, $pver, $pdata);
            $needPkgListCount--;
        }
    }

    #
    #   Delete packages that have been identified as excess
    #
    delete_pkgs:
    while ( (my ($pname, $pvers)) = each %{$excessPkgList} )
    {
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
        {
            if ( --$txcount <= 0 )
            {
                $logger->warn("Max transfer count exceeded: $excessPkgListCount deletion remaining");
                $lastReleaseScan = 0;
                last delete_pkgs;
            }

            if ( readConfig() )
            {
                $logger->warn("Config file changed");
                $lastReleaseScan = 0;
                $txcount = 0;
                last send_pkgs;
            }
            
            deletePackage ($pname, $pver, $pdata);
            $excessPkgListCount--;
        }
    }

    #
    #   Send package list to the target
    #
    sendPackageList ($pkgList);

    #
    #   On a successful transfer
    #       Force tag processing
    #       Set scan Mode to normal
    #
    $tagDirTime = 0;
    $releaseScanMode = 0;
}

#-------------------------------------------------------------------------------
# Function        : sendPackageList
#
# Description     : Transfer package list to the target
#
# Inputs          : $pkgList            - Ref to hash of package names and versions
#
# Returns         : Nothing
#                   Don't really care about any errors from this process
#                   Its not essential
#
sub sendPackageList
{
    my ($pkgList) = @_;
    my ($fh, $filename) = tempfile( "/tmp/blat.$$.XXXX", SUFFIX => '.txt');
    $logger->verbose("sendPackageList:TmpFile: $filename");
    
    #
    #   Create a temp file with data
    #
    foreach my $pname ( sort keys %{$pkgList} )
    {
        foreach my $pver ( sort keys %{$pkgList->{$pname}} )
        {
            print $fh "$pname/$pver\n";
        }
    }
    close $fh;

    #
    #   Transfer to target
    #   Create the process pipe to transfer the file
    #   gzip the file and pipe the result through a ssh session to the target machine
    #   gzip -c filename |  ssh  -i $IDENTITY  pkg_admin@${TARGET_HOST} "./receive_file filename"
    #
    my $ph;
    my $gzip_cmd = "gzip --no-name -c \"$filename\"";
    my $tgt_cmd = "$conf->{'bindir'}/receive_file \"ArchiveList\"";
    my $ssh_cmd = "ssh -o \"BatchMode yes\" -i $conf->{'identity'} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";

    $logger->verbose2("sendPackageList:gzip_cmd:$gzip_cmd");
    $logger->verbose2("sendPackageList:tgt_cmd:$tgt_cmd");
    $logger->verbose2("sendPackageList:ssh_cmd:$ssh_cmd");

    open ($ph, "$gzip_cmd | $ssh_cmd |");
    while ( <$ph> )
    {
        chomp;
        $logger->verbose2("sendPackageList:Data: $_");
    }
    close ($ph);
    $logger->verbose("sendPackageList:End: $?");
    unlink $filename;
}


#-------------------------------------------------------------------------------
# Function        : getPkgList
#
# Description     : Determine a set of package versions within the list
#                   of provided releases
#
# Inputs          : @rlist              - A list of releases to examine
#
# Returns         : Ref to a hask of package versions
#
sub getPkgList
{
    my %pdata;
    my $RM_DB;
    connectRM(\$RM_DB);
    $logger->verbose("getPkgList");

    #
    #   Determine the releases that are in this project
    #   Build up an sql query
    #
    my @m_rlist;
    push @m_rlist,"rc.RTAG_ID=$_" foreach ( @_ );
    my $m_rlist = join ' OR ', @m_rlist;
    my $m_sqlstr = "SELECT DISTINCT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.IS_DEPLOYABLE" .
                    " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
                    " WHERE ( $m_rlist ) AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID" .
                    " ORDER by PKG_NAME DESC";
    $logger->verbose3("getPkgList:Sql:$m_sqlstr");
                    
    my $sth = $RM_DB->prepare($m_sqlstr);
    if ( defined($sth) )
    {
        if ( $sth->execute( ) )
        {
            if ( $sth->rows )
            {
                while (my @row = $sth->fetchrow_array )
                {
                    $logger->verbose2("getPkgList:Data:@row");
                    $pdata{$row[1]}{$row[2]} = 1;
                }
            }
            $sth->finish();
        }
    }
    else
    {
        $logger->warn("getPkgList: SQL Prepare failure");
    }

   disconnectRM(\$RM_DB);
   return \%pdata;
}


#-------------------------------------------------------------------------------
# Function        : getReleaseList
#
# Description     : Determine the list of releases to be proccessed
#                   From:
#                       Convert projects to a list of releases
#                       Configured list of releases
#
# Inputs          : None
#
# Returns         : A list of releases to be processed
#
sub getReleaseList
{
    my $RM_DB;
    my %rlist;
    my $m_sqlstr;
    $logger->verbose("getReleaseList");

    #
    #   Cache data
    #   Only for one cycle of the main loop
    #
    if ( exists $releaseData{getReleaseList} )
    {
        $logger->verbose3("getReleaseList:Cache hit");
        return @{$releaseData{getReleaseList}};
    }

    #
    #   All projects
    #
    if ( $conf->{'allProjects'} )
    {
        $m_sqlstr = "SELECT rt.RTAG_ID" .
                    " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
                    " WHERE rt.OFFICIAL != 'A'";
                    #" AND rt.OFFICIAL != 'Y'";
    }
    else
    {
        #
        #   Convert list of projects into a list of releases
        #
        my @plist = split /[,\s]+/, $conf->{'project'} || '';
        if ( @plist )
        {
            #
            #   Determine the releases that are in this project
            #   Build up an sql query
            #
            my @m_plist;
            push @m_plist,"PROJ_ID=$_" foreach ( @plist );
            my $m_plist = join ' OR ', @m_plist;
            $m_sqlstr = "SELECT rt.RTAG_ID" .
                        " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
                        " WHERE ( $m_plist ) AND rt.OFFICIAL != 'A' AND rt.OFFICIAL != 'Y'";
        }
    }

    if ( defined $m_sqlstr )
    {
        $logger->verbose3("getReleaseList:Sql:$m_sqlstr");
        connectRM(\$RM_DB);
        my $sth = $RM_DB->prepare($m_sqlstr);
        if ( defined($sth) )
        {
            if ( $sth->execute( ) )
            {
                if ( $sth->rows )
                {
                    while (my @row = $sth->fetchrow_array )
                    {
                        $logger->verbose2("getReleaseList:Data:@row");
                        $rlist{$row[0]} = 1;
                    }
                }
                $sth->finish();
            }
        }
        else
        {
            $logger->warn("getReleaseList: SQL Prepare failure");
        }
        disconnectRM(\$RM_DB);
    }

    #
    #   Add in the user specified list of releases
    #
    my @rlist = split /[,\s]+/, $conf->{'release'} || '';
    $rlist{$_} = 1 foreach(@rlist);

    #
    #   Sort for pretty display only
    #
    @{$releaseData{getReleaseList}} = sort {$a <=> $b} keys %rlist;

    return @{$releaseData{getReleaseList}};
}

#-------------------------------------------------------------------------------
# Function        : maintainTagList
#
# Description     : Maintain a data structure for the maintenance of the
#                   tags directory
#
# Inputs          : None
#
# Returns         : Nothing
#
sub maintainTagList
{
    #
    #   Time to perform the scan
    #   Will do at startup and every time period there after
    #
    return unless ( $now > ($lastTagListScan + $conf->{tagListUpdate} ));
    $logger->verbose("maintainTagList");
    $lastTagListScan = $now;

    #
    #   Get list of things
    #
    my %config;
    %{$config{projects}} = map { $_ => 1 } split (/[,\s]+/, $conf->{'project'} || '');
    %{$config{releases}} = map { $_ => 1 } getReleaseList();

    #
    #   Save data
    #
    my $dump =  Data::Dumper->new([\%config], [qw(*config)]);
#print $dump->Dump;
#$dump->Reset;

    #
    #   Save config data
    #
    my $conf_file = catfile( $conf->{'tagdir'},'.config' );
    $logger->verbose3("maintainTagList: Writting $conf_file");

    my $fh;
    open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
    print $fh $dump->Dump;
    close $fh;
}


#-------------------------------------------------------------------------------
# Function        : processTags
#
# Description     : Process tags and send marked package versions to the target
#                       Determine if new tags are present
#                       Process each tag
#
# Inputs          : None
#
# Returns         : Nothing
#
sub processTags
{
    #
    #   Determine if new tags are present by examining the time
    #   that the directory was last modified.
    #
    #   Allow for a forced scan to catch packages that did not transfer
    #   on the first attempt
    #
    my ($mtime) = Utils::mtime($conf->{'tagdir'} );
    if ( ($mtime > $tagDirTime) || ($now > ($lastDirScan + $conf->{'forcedirscan'})) )
    {
        $logger->verbose2("processTags: ",$conf->{'tagdir'}, $mtime - $tagDirTime, $now - $lastDirScan);
        $tagDirTime = $mtime;
        $lastDirScan = $now;

        my $dh;
        unless (opendir($dh, $conf->{'tagdir'}))
        {
            $logger->warn ("can't opendir $conf->{'tagdir'}: $!");
            return;
        }

        #
        #   Process each entry
        #   Ignore those that start with a .
        #
        while (my $tag = readdir($dh) )
        {
            next if ( $tag =~ m~^\.~ );
            my $file = "$conf->{'tagdir'}/$tag";
            $logger->verbose3("processTags: $file");

            next unless ( -f $file );
            next if ( $tag  eq 'ReleaseList' );

            if ( $tag =~ m~(.+)::(.+)~  )
            {
                my $package = $1;
                my $version = $2;
                if ( transferPackage( $package, $version ))
                {
                    unlink $file;
                }
                else
                {
                    my ($mtime) = Utils::mtime( $file );
                    if ( $now - $mtime > $conf->{'tagage'} )
                    {
                        $logger->warn ("Delete unsatisfied tag: $tag");
                        unlink $file;
                    }
                }
            }
        }
        closedir $dh;
    }
}

#-------------------------------------------------------------------------------
# Function        : transferPackage
#
# Description     : Transfer specified package to target system
#
# Inputs          : $pname          - Name of the package
#                   $pver           - Package version
#                   $plink          - (optional) Symlink in same package
#
# Returns         : true    - Package transferred
#                   false   - Package not transferred
#
sub transferPackage
{
    my ($pname, $pver, $plink ) = @_;
    my $rv = 0;
    $logger->logmsg("transferPackage: @_");

    #
    #   Do not transfer excluded files
    #
    if ( exists $excludePkgs->{$pname} )
    {
        $logger->warn("transferPackage: Excluded package not transferred: $pname, $pver");
        return 1;
    }

    #
    #   Apply package filter
    #
    if ( defined $conf->{'packageFilter'} )
    {
        unless ( $pname =~ m~$conf->{'packageFilter'}~ )
        {
            $logger->warn("transferPackage: Filtered out package not transferred: $pname, $pver");
            return 1;
        }
    }

    #
    #   plink of 1 is not a symlink
    #
    $plink = undef if ( defined($plink) && $plink eq '1' );

    #
    #   If its been transferred in the current scan, then
    #   indicate that all is well
    #
    if ( $transferred->{$pname}{$pver}  )
    {
        $logger->verbose("transferPackage: Already transferred");
        return 1;
    }

    my $sfile = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
    unless ( -d $sfile )
    {
        $logger->warn("transferPackage:Package not found: $pname, $pver");
        return $rv;
    }

    #
    #   Create the process piple to transfer the package
    #   Tar the directory and pipe the result through a ssh session to
    #   the target machine
    #   gtar -czf - -C "$dpkg/${pname}/${pver}" . |  ssh  -i $IDENTITY  pkg_admin@${TARGET_HOST} "./receive_package ${rx_opts} \"$pname\" \"$pver\""
    #
    my $ph;
    my $tar_cmd = "gtar -czf - -C \"$sfile\" .";
    my $tgt_opts = defined($plink) ? "\"-L$plink\"" : '';
    my $tgt_cmd = "$conf->{'bindir'}/receive_package $tgt_opts \"$pname\" \"$pver\"";
    my $ssh_cmd = "ssh -o \"BatchMode yes\" -i $conf->{'identity'} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";

    $logger->verbose2("transferPackage:tar_cmd:$tar_cmd");
    $logger->verbose2("transferPackage:tgt_cmd:$tgt_cmd");
    $logger->verbose2("transferPackage:ssh_cmd:$ssh_cmd");

    open ($ph, "$tar_cmd | $ssh_cmd |");
    while ( <$ph> )
    {
        chomp;
        $logger->verbose2("transferPackage:Data: $_");
    }
    close ($ph);
    $logger->verbose("transferPackage:End: $?");
    if ( $? == 0 )
    {
        #
        #   Mark has having been transferred in the current cycle
        #
        $transferred->{$pname}{$pver} = 1;
        $rv = 1;
    }
    else
    {
        $logger->warn("transferPackage:Transfer Error: $pname, $pver, $?");
    }
    return $rv;
}

#-------------------------------------------------------------------------------
# Function        : deletePackage
#
# Description     : Delete specified package to target system
#
# Inputs          : $pname          - Name of the package
#                   $pver           - Package version
#                   $pdata          - Hash of extra data
#
# Returns         : true    - Package transferred
#                   false   - Package not transferred
#
sub deletePackage
{
    my ($pname, $pver, $pdata ) = @_;
    my $rv = 0;
    $logger->logmsg("deletePackage: $pname, $pver");

    #
    #   Create the process pipe to delete the package
    #   Tar the directory and pipe the result through a ssh session to
    #   the target machine
    #   gtar -czf - -C "$dpkg/${pname}/${pver}" . |  ssh  -i $IDENTITY  pkg_admin@${TARGET_HOST} "./receive_package ${rx_opts} \"$pname\" \"$pver\""
    #
    my $ph;
    my $flags = $pdata->{FORCEDELETE}  ? '' : ' -T';
    my $tgt_cmd = "$conf->{'bindir'}/delete_package $flags \"$pname\" \"$pver\"";
    my $ssh_cmd = "ssh -o \"BatchMode yes\" -i $conf->{'identity'} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";

    $logger->verbose2("deletePackage:tgt_cmd:$tgt_cmd");
    $logger->verbose2("deletePackage:ssh_cmd:$ssh_cmd");

    open ($ph, "$ssh_cmd |");
    while ( <$ph> )
    {
        chomp;
        $logger->verbose2("deletePackage:Data: $_");
    }
    close ($ph);
    $logger->verbose("deletePackage:End: $?");
    if ( $? == 0 )
    {
        $rv = 1;
    }
    else
    {
        $logger->warn("deletePackage:Error: $pname, $pver, $?");
    }
    return $rv;
}


#-------------------------------------------------------------------------------
# Function        : parsePkgList
#
# Description     : Parse one line from a pkgList
#                   Lines are multiple item="data" items
#
# Inputs          : $line                   - Line of data
#                   $hashp                  - Ref to hash to populate
#
# Returns         : A hash of data items
#
sub parsePkgList
{
    my ($line, $hashp) = @_;
    my $rv;

    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
    {
        $rv->{$1} = $2;
        $line = $';
    }
#Utils::DebugDumpData ("parsePkgList", $rv);

    my $pname = $rv->{pname};
    my $pver =  $rv->{pver};
    return undef unless ( $pname && $pver );

    delete $rv->{pname};
    delete $rv->{pver};
    delete $rv->{GMT};

    $hashp->{$pname}{$pver} = $rv;
    return $hashp;
}


#-------------------------------------------------------------------------------
# Function        : sighandlers
#
# Description     : Install signal handlers
#
# Inputs          : $conf           - System config
#
# Returns         : Nothing
#
sub sighandlers
{
        my $conf = shift;
        my $logger = $conf->{logger};

        $SIG{TERM} = sub {
                # On shutdown
                $logger->logmsg('Received SIGTERM. Shutting down....' );
                unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
                exit 0;
        };

        $SIG{HUP} = sub {
                # On logrotate
                $logger->logmsg('Received SIGHUP.');
                $logger->rotatelog();
        };

        $SIG{USR1} = sub {
                # On Force Archive Sync
                $logger->logmsg('Received SIGUSR1.');
        $lastReleaseScan = 0;
        $lastTagListScan = 0;
        };

    $SIG{__WARN__} = sub { $logger->warn("@_") };
    $SIG{__DIE__} = sub { $logger->err("@_") };
    

}

#-------------------------------------------------------------------------------
# Function        : Error, Verbose, Warning
#
# Description     : Support for JatsRmApi
#
# Inputs          : Message
#
# Returns         : Nothing
#
sub Error
{
    $logger->err("@_");
}

sub Verbose
{
    $logger->verbose2("@_");
}

sub Warning
{
    $logger->warn("@_");
}
Subversion Repositories DevTools

(root)/dpkg_blat/trunk/src/blat/blatDaemon.pl – Rev 1289
