Subversion Repositories DevTools

Rev

Rev 7469 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1038 dpurdie 1 
#! /usr/bin/perl
2 
########################################################################
7397 dpurdie 3 
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
1038 dpurdie 4 
#
5 
# Module name   : blatDaemon.pl
6 
# Module type   :
7 
# Compiler(s)   : Perl
8 
# Environment(s):
9 
#
10 
# Description   :
11 
#
12 
# Usage         :   ARGV[0] - Path to config file for this instance
13 
#
14 
#......................................................................#
15 
 
16 
require 5.008_002;
17 
use strict;
18 
use warnings;
19 
use Getopt::Long;
20 
use File::Basename;
1040 dpurdie 21 
use Data::Dumper;
22 
use File::Spec::Functions;
1038 dpurdie 23 
use POSIX ":sys_wait_h";
24 
use File::Temp qw/tempfile/;
6320 dpurdie 25 
use Digest::MD5;
1038 dpurdie 26 
 
27 
use FindBin;                                    # Determine the current directory
28 
use lib "$FindBin::Bin/lib";                    # Allow local libraries
29 
 
30 
use Utils;
31 
use StdLogger;                                  # Log to sdtout
32 
use Logger;                                     # Log to file
33 
 
34 
#
35 
#   Database interface
36 
#   Pinched from jats and modified so that this software is not dependent on JATS
37 
#
38 
use IO::Handle;
39 
use JatsRmApi;
40 
use DBI;
41 
 
42 
#
43 
#   Globals
44 
#
45 
my $logger = StdLogger->new();                  # Stdout logger. Only during config
6475 dpurdie 46 
$logger->err("No config file specified") unless (defined $ARGV[0]);
7387 dpurdie 47 
$logger->err("Config File does not exist: $ARGV[0]") unless (-f $ARGV[0]);
1038 dpurdie 48 
my $name = basename( $ARGV[0]);
49 
   $name =~ s~.conf$~~;
50 
my $now = 0;
5398 dpurdie 51 
my $startTime = 0;
3515 dpurdie 52 
my $tar = 'tar';
53 
my $gzip = 'gzip';
1038 dpurdie 54 
my $tagDirTime = 0;
55 
my $lastDirScan = 0;
56 
my $lastReleaseScan = 0;
1040 dpurdie 57 
my $releaseScanMode = 0;
6779 dpurdie 58 
my $lastTagListUpdate = 0;
6776 dpurdie 59 
my $lastRmConfRead = 0;
60 
my $lastRmConfFullRead = 0;
61 
my $lastRmSeqNum = 0;
1038 dpurdie 62 
my $mtimeConfig = 0;
63 
my $conf;
64 
my $extraPkgs;
1040 dpurdie 65 
my $excludePkgs;
66 
my %releaseData;
3515 dpurdie 67 
my $comError = 0;
5398 dpurdie 68 
my $yday = -1;
6148 dpurdie 69 
my $RemotePkgList = {};
6320 dpurdie 70 
my $targetBinDir = "$FindBin::Bin/targetBin";
6776 dpurdie 71 
my $server_id;
72 
my @projectList;
73 
my @releaseList;
7387 dpurdie 74 
my $isS3Target;
1038 dpurdie 75 
 
76 
#
5398 dpurdie 77 
#   Contain statisics maintained while operating
78 
#       Can be dumped with a kill -USR2
79 
#       List here for documentation
80 
#
81 
 
82 
my %statistics = (
83 
    SeqNum => 0,                        # Bumped when $statistics are dumped
84 
    timeStamp => 0,                     # DateTime when statistics are dumped
85 
    upTime => 0,                        # Seconds since program start
86 
    Cycle => 0,                         # Major process loop counter
87 
    phase => 'Init',                    # Current phase of operation
88 
    state => 'OK',                      # Nagios state
7397 dpurdie 89 
    wedged => 0,                        # Wedge indication - main loop not cycling
5398 dpurdie 90 
                                        #
91 
                                        # The following are reset each day
92 
    dayStart => 0,                      # DateTime when daily data was reset
93 
    txCount => 0,                       # Packages Transferred
94 
    delCount => 0,                      # Packages marked for deletion
95 
    staleTags => 0,                     # Stale Tags
96 
    linkErrors => 0,                    # Transfer errors
97 
                                        #
98 
                                        # Per Cycle Data - Calculated each processing Cycle
5399 dpurdie 99 
    total    => 0,                      # Packages to be synced
5398 dpurdie 100 
    delete   => 0,                      # Packages to delete
101 
    excluded => 0,                      # Packages excluded
102 
    filtered => 0,                      # Packages filtered out
103 
    missing  => 0,                      # Packages missing
104 
    transfer => 0,                      # Packages to transfer
105 
    writable => 0,                      # Packages still writable - thus not transferred
106 
    tagCount => 0,                      # Packages tagged to be transferred
7394 dpurdie 107 
    tagDelCount => 0,                   # Packages tagged to be deleted
5404 dpurdie 108 
                                        #
109 
                                        # Expected from the Target
110 
#   Target.Hostname => '',              # Target Hostname
111 
#   Target.avail    => 0,               # Information from 'df' 1Kblocks
112 
#   Target.pcent    => 0,
113 
#   Target.size     => 0,
114 
#   Target.used     => 0,
115 
#   Target.iavail   => 0,               # Inode information from 'df'
116 
#   Target.ipcent   => 0,
117 
#   Target.isize    => 0,
118 
#   Target.iused    => 0,
119 
#   Target.Total    => 0,               # Number of Package Versions in the archive
120 
#   Target.Damaged  => 0,               # Number that are damaged
121 
#   Target.Delete   => 0,               # Number marked for future deletion
122 
#   Target.Missing  => 0,               # Number missing
5398 dpurdie 123 
);
124 
 
1038 dpurdie 125 
#
5398 dpurdie 126 
#   Describe configuration parameters
127 
#
1038 dpurdie 128 
my %cdata = (
129 
    '.ignore'         => {'pkg\.(.+)' => 'pkgs' },
7387 dpurdie 130 
    '.oneOf'          => [['hostname','S3Bucket']] ,
131 
 
1048 dpurdie 132 
    'piddir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
133 
    'sleep'           => {'default'   => 5      , 'fmt' => 'period'},
134 
    'dpkg_archive'    => {'mandatory' => 1      , 'fmt' => 'dir'},
135 
    'logfile'         => {'mandatory' => 1      , 'fmt' => 'vfile'},
136 
    'logfile.size'    => {'default'   => '1M'   , 'fmt' => 'size'},
137 
    'logfile.count'   => {'default'   => 9      , 'fmt' => 'int'},
138 
    'verbose'         => {'default'   => 0      , 'fmt' => 'int'},
6776 dpurdie 139 
    'rmHostName'      => {'default'   => undef  , 'fmt' => 'text'},
3847 dpurdie 140 
    'sshport'         => {'default'   => 0      , 'fmt' => 'int'},
7397 dpurdie 141 
    'tagdir'          => {'mandatory' => 1      , 'fmt' => 'mkdir'},
1048 dpurdie 142 
    'forcedirscan'    => {'default'   => 100    , 'fmt' => 'period'},
143 
    'tagage'          => {'default'   => '10m'  , 'fmt' => 'period'},
144 
    'tagListUpdate'   => {'default'   => '1h'   , 'fmt' => 'period'},
7387 dpurdie 145 
    'tagMaxPackages'  => {'default'   => 10     , 'fmt' => 'int'},
6776 dpurdie 146 
    'rmConfigCheck'   => {'default'   => '60'   , 'fmt' => 'period'},
147 
    'rmConfFullRead'  => {'default'   => '1h'   , 'fmt' => 'period'},
1048 dpurdie 148 
    'synctime'        => {'default'   => '2h'   , 'fmt' => 'period'},
149 
    'syncretry'       => {'default'   => '5m'   , 'fmt' => 'period'},
150 
    'allProjects'     => {'default'   => 0      , 'fmt' => 'bool'},
4456 dpurdie 151 
    'allArchive'      => {'default'   => 0      , 'fmt' => 'bool'},
1048 dpurdie 152 
    'project'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
153 
    'release'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
154 
    'writewindow'     => {'default'   => '3h'   , 'fmt' => 'period'},
155 
    'maxpackages'     => {'default'   => 5      , 'fmt' => 'int'},
156 
    'deletePackages'  => {'default'   => 0      , 'fmt' => 'bool'},
157 
    'deleteImmediate' => {'default'   => 0      , 'fmt' => 'bool'},
158 
    'deleteAge'       => {'default'   => 0      , 'fmt' => 'period'},
159 
    'packageFilter'   => {'default'   => undef  , 'fmt' => 'text'},
160 
    'active'          => {'default'   => 1      , 'fmt' => 'bool'},
6475 dpurdie 161 
    'debug'           => {'default'   => 0      , 'fmt' => 'bool'},                 # Log to screen
162 
    'txdetail'        => {'default'   => 0      , 'fmt' => 'bool'},
6776 dpurdie 163 
    'noTransfers'     => {'default'   => 0      , 'fmt' => 'bool'},                 # Debugging option to prevent transfers
7394 dpurdie 164 
    'maxTarZips'      => {'default'   => 5      , 'fmt' => 'int'},
7460 dpurdie 165 
    'wedgeTime'       => {'default'   => '30m'  , 'fmt' => 'period'},
7469 dpurdie 166 
    'allNewPkgs'      => {'default'   => 0      , 'fmt' => 'bool'},
7387 dpurdie 167 
 
168 
    #
169 
    #   Transfer via ssh
170 
    #   Cannot be used in conjunction with S3Bucket
171 
    #
7460 dpurdie 172 
    'hostname'        => {'fmt' => 'text', 'requires' => 'user,identity,bindir'},
173 
    'user'            => {'fmt' => 'text', 'requires' => 'hostname'},
7387 dpurdie 174 
    'identity'        => {'fmt' => 'file'},
175 
    'bindir'          => {'fmt' => 'text'},
176 
 
177 
    #
178 
    #   Transfer to S3 configuration items
179 
    #       Cannot be used in conjunction with hostname
180 
    #       Many other options will be ignored
181 
    #
7460 dpurdie 182 
    'S3Bucket'        => {'fmt' => 'text', 'requires' => 'S3Profile,S3Profile,S3Region'},
183 
    'S3Profile'       => {'fmt' => 'text', 'requires' => 'S3Bucket' },
184 
    'S3Region'        => {'fmt' => 'text', 'requires' => 'S3Bucket' },
185 
    'S3AllowDelete'   => {'default' => 0 , 'fmt' => 'bool'},
1038 dpurdie 186 
);
187 
 
188 
 
189 
#
190 
#   Read in the configuration
191 
#       Set up a logger
192 
#       Write a pidfile - thats not used
6776 dpurdie 193 
$now = $startTime = time();
1038 dpurdie 194 
readConfig();
195 
Utils::writepid($conf);
196 
$logger->logmsg("Starting...");
5404 dpurdie 197 
readStatistics();
7423 dpurdie 198 
sighandlers();
1038 dpurdie 199 
 
200 
#
201 
#   Main processing loop
202 
#   Will exit when terminated by parent
203 
#
6779 dpurdie 204 
while (1)
1038 dpurdie 205 
{
206 
    $logger->verbose3("Processing");
5398 dpurdie 207 
    $statistics{Cycle}++;
1038 dpurdie 208 
    $now = time();
7460 dpurdie 209 
    Utils::resetWedge();
1040 dpurdie 210 
 
5398 dpurdie 211 
    $statistics{phase} = 'ReadConfig';
1038 dpurdie 212 
    readConfig();
1048 dpurdie 213 
    if ( $conf->{'active'} )
214 
    {
5398 dpurdie 215 
        $statistics{phase} = 'ProcessReleaseList';
1048 dpurdie 216 
        processReleaseList();
5398 dpurdie 217 
        $statistics{phase} = 'processTags';
1048 dpurdie 218 
        processTags();
5398 dpurdie 219 
        $statistics{phase} = 'maintainTagList';
1048 dpurdie 220 
        maintainTagList();
221 
    }
1040 dpurdie 222 
    %releaseData = ();
223 
 
5398 dpurdie 224 
    $statistics{phase} = 'Sleep';
1038 dpurdie 225 
    sleep( $conf->{'sleep'} );
6779 dpurdie 226 
    reapChildren();
1050 dpurdie 227 
 
3847 dpurdie 228 
    #   If my PID file ceases to be, then exit the daemon
229 
    #   Used to force daemon to restart
230 
    #
231 
    unless ( -f $conf->{'pidfile'} )
232 
    {
233 
        $logger->logmsg("Terminate. Pid file removed");
234 
        last;
235 
    }
1038 dpurdie 236 
}
5398 dpurdie 237 
$statistics{phase} = 'Terminated';
1038 dpurdie 238 
$logger->logmsg("Child End");
239 
exit 0;
240 
 
241 
#-------------------------------------------------------------------------------
6779 dpurdie 242 
# Function        : reapChildren
243 
#
244 
# Description     : Reap any and all dead children
245 
#                   Call in major loops to prevent zombies accumulating
246 
#
247 
# Inputs          : None
248 
#
249 
# Returns         :
250 
#
251 
sub reapChildren
252 
{
253 
    my $currentPhase = $statistics{phase};
254 
    $statistics{phase} = 'Reaping';
255 
 
256 
    my $kid;
257 
    do {
258 
        $kid = waitpid(-1, WNOHANG);
259 
    } while ( $kid > 0 );
260 
 
261 
    $statistics{phase} = $currentPhase;
262 
}
263 
 
264 
 
265 
#-------------------------------------------------------------------------------
1038 dpurdie 266 
# Function        : readConfig
267 
#
268 
# Description     : Re read the config file if it modification time has changed
269 
#
270 
# Inputs          : Nothing
271 
#
1289 dpurdie 272 
# Returns         : 0       - Config not read
273 
#                   1       - Config read
274 
#                             Config file has changed
1038 dpurdie 275 
#
276 
sub readConfig
277 
{
278 
    my ($mtime) = Utils::mtime($ARGV[0]);
1289 dpurdie 279 
    my $rv = 0;
280 
 
1038 dpurdie 281 
    if ( $mtimeConfig != $mtime )
282 
    {
283 
        $logger->logmsg("Reading config file: $ARGV[0]");
284 
        $mtimeConfig = $mtime;
285 
        my $errors;
286 
        ($conf, $errors) = Utils::readconf ( $ARGV[0], \%cdata );
287 
        if ( scalar @{$errors} > 0 )
288 
        {
289 
            warn "$_\n" foreach (@{$errors});
290 
            die ("Config contained errors\n");
291 
        }
7387 dpurdie 292 
        $isS3Target = defined $conf->{'S3Bucket'};
7460 dpurdie 293 
        if ($isS3Target) {
294 
            if (!$conf->{'S3AllowDelete'}) {
295 
                    $conf->{deletePackages} = 0;
296 
            }
297 
        }
1038 dpurdie 298 
 
299 
        #
300 
        #   Reset some information
301 
        #   Create a new logger
302 
        #
7387 dpurdie 303 
        $logger = Logger->new($conf) unless $conf->{debug};
1038 dpurdie 304 
        $conf->{logger} = $logger;
305 
        $conf->{'pidfile'} = $conf->{'piddir'} . '/' . $name . '.pid';
7387 dpurdie 306 
        $logger->setVerbose($conf->{verbose});
1038 dpurdie 307 
        $logger->verbose("Log Levl: $conf->{verbose}");
308 
 
309 
        #
5398 dpurdie 310 
        #   Setup statistics filename
311 
        $conf->{'statsfile'} = $conf->{'piddir'} . '/' . $name . '.stats';
312 
        $conf->{'statsfiletmp'} = $conf->{'piddir'} . '/' . $name . '.stats.tmp';
313 
 
314 
        #
1038 dpurdie 315 
        #   Extract extra package config
6475 dpurdie 316 
        #       Ignore ALL and Version info if transferring the entire archive
317 
        #       Honor the EXCLUDE - for bandwidth reasons
7387 dpurdie 318 
        #
319 
        #   NOTE: Package inclusion will not be processed in allArchive mode
320 
        #   BUG:  This processing should be done after the RmConfig has been included
1038 dpurdie 321 
        #
322 
        $extraPkgs = {};
1040 dpurdie 323 
        $excludePkgs = {};
1038 dpurdie 324 
        while (my($key, $data) = each ( %{$conf->{pkgs}} ))
325 
        {
3846 dpurdie 326 
            if ( $data eq 'EXCLUDE' ) {
1040 dpurdie 327 
                $excludePkgs->{$key} = 1;
328 
                $logger->verbose("Exclude Pkg: $key");
3846 dpurdie 329 
 
330 
            } elsif ( $data eq 'ALL' ) {
6475 dpurdie 331 
                next if ( $conf->{'allArchive'} );
3846 dpurdie 332 
                foreach my $pver (getPackageVersions($key))
333 
                {
334 
                    $extraPkgs->{$key}{$pver} = 1;
335 
                    $logger->verbose("Extra Pkg: $key -> $pver");
336 
                }
337 
            } else {
6475 dpurdie 338 
                next if ( $conf->{'allArchive'} );
339 
                foreach (split(/[,\s]+/, $data))
340 
                {
341 
                    $extraPkgs->{$key}{$_} = 1;
342 
                    $logger->verbose("Extra Pkg: $key -> $_");
343 
                }
1040 dpurdie 344 
            }
1038 dpurdie 345 
        }
1046 dpurdie 346 
 
1048 dpurdie 347 
        $logger->verbose("Filter Packages: " . $conf->{'packageFilter'})
348 
            if ( defined $conf->{'packageFilter'} );
349 
 
3847 dpurdie 350 
        $logger->warn("Non standard ssh port: " . $conf->{'sshport'})
351 
            if ( $conf->{'sshport'} );
1048 dpurdie 352 
 
6776 dpurdie 353 
        #
354 
        #   Save Text based config for use in RmConfig
355 
        #
356 
        $conf->{'BaseActive'} = $conf->{'active'};
1048 dpurdie 357 
 
6776 dpurdie 358 
        #
359 
        #   Flag config has changed / been read
360 
        #   Force full RM data fetch
361 
        #
362 
        $rv = 1;
363 
        $lastRmSeqNum = 0;
364 
        $lastRmConfRead = 0;
365 
    }
4456 dpurdie 366 
 
6776 dpurdie 367 
    #
368 
    #   Read the Release Manager configuration too
369 
    #
370 
    $rv |= ReadRmConfig();
371 
 
372 
    #
373 
    #   When config is read force some actions
374 
    #       - Force tagList to be created
375 
    #       - Force release scan
376 
    if ($rv) {
6779 dpurdie 377 
        $lastTagListUpdate = 0;
1050 dpurdie 378 
        $lastReleaseScan = 0;
6776 dpurdie 379 
 
380 
        #
381 
        #   Update global Project/Release list - only on change
382 
        @projectList = split /[,\s]+/, $conf->{'project'} || '';
383 
        @releaseList = split /[,\s]+/, $conf->{'release'} || '';
384 
 
385 
        $logger->logmsg("projectList: ". join(',',@projectList));
386 
        $logger->logmsg("releaseList: ". join(',',@releaseList));
387 
 
388 
#Utils::DebugDumpData ("Config", $conf);
389 
 
390 
        $logger->warn("Transfer session configured as not active") unless ( $conf->{'active'} );
391 
        $logger->warn("Transfer all project packages") if ( $conf->{'allProjects'} );
392 
        $logger->warn("Transfer entire package archive") if ( $conf->{'allArchive'} );
393 
        $logger->warn("All Transfers disabled") if ( $conf->{'noTransfers'} );
7387 dpurdie 394 
        $logger->warn("Transfer to AWS S3 Bucket") if ( $isS3Target );
6776 dpurdie 395 
    }
396 
 
397 
    return $rv;
398 
}
399 
 
400 
#-------------------------------------------------------------------------------
401 
# Function        : ReadRmConfig
402 
#
403 
# Description     : Read Configuration information from Release Manager
404 
#                   If Rm configuration is to be used then it will override
405 
#                   the project/release configuration in the text file
406 
#
407 
#
408 
# Inputs          : Nothing
409 
#
410 
# Returns         : 0       - Config not read
411 
#                   1       - Config read
412 
#                             Config file has changed
413 
#
414 
sub ReadRmConfig
415 
{
416 
    #
417 
    #   Time to perform a database read
418 
    #   Will do at startup and every time period there after
419 
    #
420 
    return 0 unless $conf->{'rmHostName'};
421 
    return 0 unless $conf->{'BaseActive'};
422 
    return 0 unless ( $now > ($lastRmConfRead + $conf->{rmConfigCheck} ));
423 
    $logger->verbose("ReadRmConfig");
424 
    $lastRmConfRead = $now;
425 
 
426 
    my $rv = 0;
427 
    my $RM_DB;
428 
    my ($blat_seqnum, $blat_mode, $found);
429 
    my $server_enabled = 1;
430 
 
431 
    #
432 
    #   Read the BLAT_SERVER record from Release Manager
433 
    #
434 
    my $m_sqlstr = "select blat_id, blat_enable, blat_seqnum, blat_mode from RELEASE_MANAGER.blat_servers WHERE UPPER(BLAT_SERVER_NAME) = UPPER('$conf->{'rmHostName'}')";
435 
 
436 
    connectRM(\$RM_DB);
437 
    my $sth = $RM_DB->prepare($m_sqlstr);
438 
    if ( defined($sth) )
439 
    {
440 
        if ( $sth->execute( ) )
441 
        {
442 
            if ( $sth->rows )
443 
            {
444 
                while (my @row = $sth->fetchrow_array )
445 
                {
446 
                    $logger->verbose2("ReadRmConfig:Data:@row");
447 
 
448 
                    $server_id = $row[0] || 0;
449 
                    $server_enabled = ($row[1] || 'N') eq 'Y';
450 
                    $blat_seqnum = $row[2] || 0;
451 
                    $blat_mode = ($row[3] || 'N');
452 
                    $found = 1;
453 
                    last;
454 
                }
455 
            }
456 
            $sth->finish();
457 
        }
458 
        else
459 
        {
460 
            $logger->warn("ReadRmConfig: SQL Execute failure");
461 
        }
462 
    }
463 
    else
464 
    {
465 
        $logger->warn("ReadRmConfig: SQL Prepare failure");
466 
    }
467 
    disconnectRM(\$RM_DB);
468 
 
469 
    #
470 
    #   Process the extracted data
471 
    #
472 
    if ( !$found) {
473 
        $logger->warn("No Release Manager configuration for:" . $conf->{'rmHostName'});
474 
        $server_id = 0;
475 
        $lastRmSeqNum = 0;
476 
        return 0;
477 
    }
478 
 
479 
    #       Check for a change in config
480 
    #
481 
    if ($lastRmSeqNum != $blat_seqnum) {
1289 dpurdie 482 
        $rv = 1;
6776 dpurdie 483 
        $lastRmSeqNum = $blat_seqnum;
1038 dpurdie 484 
    }
6776 dpurdie 485 
 
486 
    #
487 
    #   Insert server configuration into the global config table
488 
    #   Rm Config will override the text config
489 
    #
490 
    $conf->{'active'} = $server_enabled;
491 
    $conf->{'allProjects'} = $blat_mode eq 'P';
492 
    $conf->{'allArchive'} =  $blat_mode eq 'E';
493 
 
494 
    #
495 
    #   If the config has changed, then read the Project and Release records from the database
496 
    #   Insert these into the config provided by the text file confing
497 
    #
498 
    my $forceFullRead;
499 
    if ( $now > ($lastRmConfFullRead + $conf->{rmConfFullRead} )) {
500 
        $logger->verbose("ForceReadRmConfig");
501 
        $lastRmConfFullRead = $now;
502 
        $forceFullRead = 1;
503 
    }
504 
 
505 
    if ($rv || $forceFullRead) {
506 
        connectRM(\$RM_DB);
507 
        my @projects;
508 
        my @releases;
509 
 
510 
        my $m_sqlstr = "select proj_id as proj_id, null as rtag_id from release_manager.blat_projects where blat_id = $server_id and UPPER(bp_enabled) = 'Y'" .
511 
                       " UNION " .
512 
                       "select null as proj_id, rtag_id rtag_id from release_manager.blat_releases where blat_id = $server_id and UPPER(br_enabled) = 'Y'";
513 
 
514 
        my $sth = $RM_DB->prepare($m_sqlstr);
515 
        if ( defined($sth) )
516 
        {
517 
            if ( $sth->execute( ) )
518 
            {
519 
                if ( $sth->rows )
520 
                {
521 
                    while (my @row = $sth->fetchrow_array )
522 
                    {
523 
                        $logger->verbose2("ReadRmConfig:Data:@row");
524 
                        push (@projects, $row[0]) if ($row[0]);
525 
                        push (@releases, $row[1]) if ($row[1] );
526 
                    }
527 
                }
528 
                $sth->finish();
529 
            }
530 
            else
531 
            {
532 
                $logger->warn("ReadRmConfig: SQL Execute failure");
533 
            }
534 
        }
535 
        else
536 
        {
537 
            $logger->warn("ReadRmConfig: SQL Prepare failure");
538 
        }
539 
        disconnectRM(\$RM_DB);
540 
 
541 
        #
542 
        #   Reform the projects and releases into a comma separated list and detect changes
543 
        #
544 
        my $projects = join(',', sort @projects);
545 
        my $releases = join(',', sort @releases);
546 
 
547 
        if ((($projects || '') ne ($conf->{'project'} || '')) || (($releases || '') ne  ($conf->{'release'} || ''))) {
548 
            $conf->{'project'} = $projects;
549 
            $conf->{'release'} = $releases;
550 
            $rv = 1;
551 
        }
552 
    }
553 
 
554 
    # Indicate if the config has changed
1289 dpurdie 555 
    return $rv;
1038 dpurdie 556 
}
557 
 
6475 dpurdie 558 
#-------------------------------------------------------------------------------
559 
# Function        : checkForBasicTools
560 
#
561 
# Description     : Check that the target has the basic tools are installed
562 
#                   Can populate the target's bin directory with tools
563 
#
564 
# Inputs          : None
565 
#
566 
# Returns         : Nothing
567 
#
568 
sub checkForBasicTools
569 
{
7387 dpurdie 570 
    return if $isS3Target;
571 
 
6475 dpurdie 572 
    my $ph;
573 
    my $found;
574 
    my $tgt_cmd = "if [ -x  $conf->{'bindir'}/get_plist.pl ] ; then echo :FOUND:; fi";
575 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 576 
 
6475 dpurdie 577 
    $logger->verbose2("checkForBasicTools:ssh_cmd:$ssh_cmd");
578 
    open ($ph, "$ssh_cmd |");
579 
    while ( <$ph> )
580 
    {
581 
        chomp;
582 
        if (m~:FOUND:~) {
583 
            $found = 1;
584 
        }
585 
        $logger->verbose2("checkForBasicTools:Data: $_");
586 
    }
587 
    close ($ph);
588 
    my $exitCode = $? >> 8;
589 
    $logger->verbose2("checkForBasicTools:End: $exitCode, $?");
590 
 
591 
    unless ( $found )
592 
    {
593 
        $logger->warn("checkForBasicTools: None found, $?");
594 
 
595 
        #
596 
        #   The 'get_plist.pl' program was not found
597 
        #   Assume that the entire directory does not exist and transfer all
598 
        #
599 
        transferTargetBin();
600 
    }
601 
}
602 
 
1038 dpurdie 603 
#-------------------------------------------------------------------------------
6475 dpurdie 604 
# Function        : transferTargetBin
605 
#
606 
# Description     : Ensure that the targets 'bin' folder is upto date
607 
#
608 
# Inputs          : $blatBinData    - Ref to array of target data file info
609 
#
610 
# Returns         :
611 
#
612 
sub transferTargetBin
613 
{
7389 dpurdie 614 
    return if $isS3Target;
6475 dpurdie 615 
    my ($blatBinData) = @_;
616 
 
617 
    my $blatBinList = getBlatBin();
618 
    foreach my $file ( keys %{$blatBinList} )
619 
    {
620 
        if (defined $blatBinData && exists $blatBinData->{$file}) {
621 
            if ($blatBinData->{$file} eq $blatBinList->{$file}) {
622 
                delete $blatBinList->{$file};
623 
            }
624 
        }
625 
    }
626 
#Utils::DebugDumpData ("blatBinList", $blatBinList);
627 
    transferBlatBin($blatBinList);
628 
}
629 
 
630 
#-------------------------------------------------------------------------------
1038 dpurdie 631 
# Function        : processReleaseList
632 
#
633 
# Description     : Process the release list
634 
#                       Determine if its time to process release list
635 
#                       Determine release list
636 
#                       Determine release content
637 
#                       Determine new items
638 
#
639 
# Inputs          : None
640 
#
641 
# Returns         : Nothing
642 
#
643 
sub processReleaseList
644 
{
645 
    #
1044 dpurdie 646 
    #   Is Release List Processing active
647 
    #   Can configure blat to disable release sync
648 
    #   This will then allow 'new' packages to be sent
649 
    #
7389 dpurdie 650 
    if ( $conf->{maxpackages} == 0 || $conf->{'synctime'} <= 0 )
1044 dpurdie 651 
    {
652 
        $logger->verbose2("processReleaseList disabled");
7387 dpurdie 653 
        $RemotePkgList = {};
1044 dpurdie 654 
        return;
655 
    }
656 
 
657 
    #
1038 dpurdie 658 
    #   Time to perform the scan
659 
    #   Will do at startup and every time period there after
660 
    #
1040 dpurdie 661 
    my $wtime = $releaseScanMode ? $conf->{'syncretry'} : $conf->{'synctime'};
662 
    return unless ( $now > ($lastReleaseScan + $wtime ));
1038 dpurdie 663 
    $logger->verbose("processReleaseList");
664 
    $lastReleaseScan = $now;
1040 dpurdie 665 
    $releaseScanMode = 1;                                   # Assume error
1038 dpurdie 666 
 
667 
    #
6772 dpurdie 668 
    #   Ensure that we have the basic tools for the transfer
669 
    #
670 
    checkForBasicTools();
671 
 
672 
    #
1038 dpurdie 673 
    #   Get list of packages from Remote site
674 
    #
675 
    my $remotePkgList;
5404 dpurdie 676 
    my $remoteData;
6320 dpurdie 677 
    my $blatBinData;
1038 dpurdie 678 
 
7389 dpurdie 679 
    #
680 
    #   Get Data from an S3 bucket
681 
    #   Can only get a part of the full data set. The timestamp can't be processed, so set it to -1
682 
    #
683 
    if ($isS3Target ) {
684 
        my $ph;
7460 dpurdie 685 
        my $tgt_cmd = "aws --profile $conf->{'S3Profile'}";
686 
        $tgt_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
687 
        $tgt_cmd .= " s3 ls $conf->{'S3Bucket'}/";
7389 dpurdie 688 
 
689 
        $logger->verbose2("processReleaseList:s3_cmd:$tgt_cmd");
690 
        open ($ph, "$tgt_cmd |");
691 
        while ( <$ph> )
1038 dpurdie 692 
        {
7389 dpurdie 693 
            chomp;
7460 dpurdie 694 
            if (m~.*\s(.*)__(.*).tgz$~ ) {
695 
                $remotePkgList->{$1}{$2}{s3} = 1;
696 
            }
1038 dpurdie 697 
        }
7389 dpurdie 698 
        close ($ph);
699 
 
700 
    } else {
701 
        # Get Data from a dpkg_archive maintained via ssh
702 
        #   Invoke a program on the remote site and parse the results
703 
        #
704 
        #   Returned data looks like:
705 
        #       Metadata avail="140100452"
706 
        #       BlatBin MD5="9e2c6e45af600a20a01dbcb7570da1f1" file="stat.pl"
707 
        #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
708 
        #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" "link=latest"
709 
        #       time="1497954104" GMT="Tue Jun 20 10:21:44 2017" pname="ERGissaccounts" pver="1.0.7178.mas" deleted="0"
710 
 
711 
        my $ph;
712 
        my $tgt_cmd = "$conf->{'bindir'}/get_plist.pl";
713 
        my $ssh_cmd = sshCmd($tgt_cmd);
714 
 
715 
        $logger->verbose2("processReleaseList:ssh_cmd:$ssh_cmd");
716 
        open ($ph, "$ssh_cmd |");
717 
        while ( <$ph> )
6320 dpurdie 718 
        {
7389 dpurdie 719 
            chomp;
720 
            if ($_ =~ m~^Metadata\s+~)
5404 dpurdie 721 
            {
7389 dpurdie 722 
                parsePkgMetaData($_, \%{$remoteData});
5404 dpurdie 723 
            }
7389 dpurdie 724 
            elsif ($_ =~ m~^BlatBin\s+~)
725 
            {
726 
                parseBlatBinData($_, \%{$blatBinData})
727 
            }
5404 dpurdie 728 
            else
729 
            {
7389 dpurdie 730 
                if ( parsePkgList($_, \%{$remotePkgList} ) )
731 
                {
732 
                    $logger->verbose2("processReleaseList:Data: $_");
733 
                }
734 
                else
735 
                {
736 
                    $logger->warn("processReleaseList:Bad Data: $_");
737 
                }
5404 dpurdie 738 
            }
1038 dpurdie 739 
        }
7389 dpurdie 740 
        close ($ph);
1038 dpurdie 741 
    }
742 
    $logger->verbose("processReleaseList:End: $?");
6148 dpurdie 743 
    $RemotePkgList = $remotePkgList;
744 
 
3515 dpurdie 745 
    LogTxError ($?);
1038 dpurdie 746 
    if ( $? != 0 )
747 
    {
748 
        $logger->warn("Cannot retrieve package list: $?");
5398 dpurdie 749 
        $statistics{state} = 'No Remote Package List';
1038 dpurdie 750 
        return;
751 
    }
1042 dpurdie 752 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
6320 dpurdie 753 
 
1038 dpurdie 754 
    #
6475 dpurdie 755 
    #   Ensure that the target bin folder is up to date
756 
    #
757 
    transferTargetBin($blatBinData);
6320 dpurdie 758 
 
759 
    #
1038 dpurdie 760 
    #   Determine the set of packages in the releases to be transferred
4456 dpurdie 761 
    #
762 
    my $pkgList;
763 
    if ( $conf->{'allArchive'} )
1040 dpurdie 764 
    {
4456 dpurdie 765 
        #   Examine entire archive
766 
        #
767 
        $pkgList = getArchiveList();
1040 dpurdie 768 
    }
4456 dpurdie 769 
    else
770 
    {
771 
        #   Examine Releases
772 
        #
773 
        my @rlist = getReleaseList();
774 
        unless ( @rlist )
775 
        {
776 
            $logger->verbose2("No Releases to Process");
5398 dpurdie 777 
            $statistics{state} = 'No Releases found';
6475 dpurdie 778 
 
779 
            #   Allow config with just specified packages
780 
            #
781 
            #   return;
782 
        } else {
783 
            $pkgList = getPkgList(@rlist);
4456 dpurdie 784 
        }
785 
    }
1038 dpurdie 786 
 
787 
    #
788 
    #   Append extra packages
789 
    #   These are packages that are specifically named by the user
790 
    #
6475 dpurdie 791 
    #   Note: If they are symbolic links, then the target of the
792 
    #         link is also added.
1038 dpurdie 793 
    #
794 
    #         Symlink MUST be within the same directory
3846 dpurdie 795 
    #           Used to transfer jats2_current
1038 dpurdie 796 
    #
797 
    while ( (my ($pname, $pvers)) = each %{$extraPkgs} ) {
798 
        while ( (my ($pver, $pdata) ) = each %{$pvers} ) {
799 
 
1040 dpurdie 800 
            my $epath = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
1038 dpurdie 801 
            if ( -l $epath )
802 
            {
803 
                my $lver = readlink( $epath );
804 
                if ( ! defined $lver )
805 
                {
3846 dpurdie 806 
                    $logger->warn("Can't resolve symlink: $pname, $pver");
1038 dpurdie 807 
                    next;
808 
                }
809 
 
810 
                if ( $lver =~ m ~/~ )
811 
                {
812 
                    $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
813 
                    next;
814 
                }
6098 dpurdie 815 
 
6475 dpurdie 816 
                #
817 
                #   Add the package the link points to
818 
                #
819 
                $logger->verbose2("Add linked package: $pname, $lver, $pdata");
820 
                $pkgList->{$pname}{$lver} = $pdata;
7389 dpurdie 821 
 
822 
                if ($isS3Target) {
823 
                    $logger->verbose2("Won't send symlink to S3: $pname, $pver, $lver");
824 
                    next;
825 
                }
826 
 
1038 dpurdie 827 
            }
828 
 
829 
            $logger->verbose2("Add extra package: $pname, $pver, $pdata");
830 
            $pkgList->{$pname}{$pver} = $pdata;
831 
        }
832 
    }
6475 dpurdie 833 
#Utils::DebugDumpData ("parsePkgList", $rv);
7389 dpurdie 834 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
1038 dpurdie 835 
 
6475 dpurdie 836 
 
1040 dpurdie 837 
    #
838 
    #   If there are no packages to process, then assume that this is an error
839 
    #   condition. Retry the operation soon.
840 
    #
841 
    unless ( keys %{$pkgList} )
842 
    {
843 
 
844 
        $logger->verbose2("No packages to process");
5398 dpurdie 845 
        $statistics{state} = 'No Packages found';
1040 dpurdie 846 
        return;
847 
    }
848 
 
6475 dpurdie 849 
#   #
850 
#   #   Useful debug code
851 
#   #
852 
#   while ( (my ($pname, $pvers)) = each %{$pkgList} )
853 
#   {
854 
#       while ( (my ($pver, $ptime) ) = each %{$pvers} )
855 
#       {
856 
#           print "L-- $pname, $pver, $ptime \n";
1038 dpurdie 857 
#
6475 dpurdie 858 
#       }
859 
#   }
1038 dpurdie 860 
 
861 
    #
1040 dpurdie 862 
    #   Delete Excess Packages
1038 dpurdie 863 
    #       Packages not required on the target
1042 dpurdie 864 
    #           KLUDGE: Don't delete links to packages
865 
    #           Don't delete packages marked for deletion
1038 dpurdie 866 
    #
867 
    my $excessPkgList;
1048 dpurdie 868 
    my $excessPkgListCount = 0;
1038 dpurdie 869 
    if ( $conf->{deletePackages} )
870 
    {
871 
        while ( (my ($pname, $pvers)) = each %{$remotePkgList} )
872 
        {
873 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
874 
            {
875 
                if ( !exists $pkgList->{$pname}{$pver} )
876 
                {
1040 dpurdie 877 
                    if ( exists $excludePkgs->{$pname} )
878 
                    {
879 
                        $logger->verbose2("Keep Excluded package: ${pname}");
880 
                        next;
881 
                    }
882 
 
1042 dpurdie 883 
                    if ( exists $pdata->{deleted} )
884 
                    {
885 
                        if ( $conf->{deleteAge} )
886 
                        {
887 
                            if ( $pdata->{deleted} <= $conf->{deleteAge} )
888 
                            {
889 
                                $logger->verbose2("Already marked for future age deletion: ${pname}/${pver}, $pdata->{deleted}");
890 
                                next;
891 
                            }
892 
                            $pdata->{FORCEDELETE} = 1;
893 
                        }
894 
 
895 
                        if ( !$conf->{deleteImmediate} )
896 
                        {
897 
                            $logger->verbose2("Already marked for deletion: ${pname}/${pver}");
898 
                            next;
899 
                        }
900 
                    }
901 
 
902 
                    #
903 
                    #   Force deletion
904 
                    #       deleteImmediate mode
905 
                    #       target is a broken link
906 
                    #
907 
                    $pdata->{FORCEDELETE} = 1
908 
                        if ($conf->{deleteImmediate} || $pdata->{broken});
909 
 
1038 dpurdie 910 
                    $excessPkgList->{$pname}{$pver} = $pdata;
1048 dpurdie 911 
                    $excessPkgListCount++;
1038 dpurdie 912 
                    $logger->verbose("Excess package: ${pname}/${pver}");
913 
                }
1050 dpurdie 914 
#                else
915 
#                {
916 
#                        $logger->verbose3("Retain package: ${pname}/${pver}");
917 
#                }
1038 dpurdie 918 
            }
919 
        }
920 
    }
921 
 
922 
    #
923 
    #   Process the remote list and the local list
924 
    #   The remote time-stamp is the modification time of the packages descpkg file
925 
    #
926 
    #   Mark for transfer packages that
1040 dpurdie 927 
    #       Are in the local set but not the remote set
1038 dpurdie 928 
    #       Have a different time stamp
929 
    #
930 
    #   Ignore packages not in the local archive
931 
    #   Ignore packages that don't have a descpkg
932 
    #   Ignore packages that are writable - still being formed
933 
    #
934 
    my $needPkgList;
1048 dpurdie 935 
    my $needPkgListCount = 0;
936 
    my $filteredCount = 0;
937 
    my $missingCount = 0;
938 
    my $writableCount = 0;
939 
    my $excludeCount = 0;
5404 dpurdie 940 
    my $packageVersionCount = 0;
1038 dpurdie 941 
    while ( (my ($pname, $pvers)) = each %{$pkgList} )
942 
    {
1040 dpurdie 943 
        #
944 
        #   Ignore excluded packages
945 
        #
1048 dpurdie 946 
        if ( exists $excludePkgs->{$pname} )
947 
        {
948 
            $excludeCount++;
949 
            next;
950 
        }
1040 dpurdie 951 
 
1048 dpurdie 952 
        #
953 
        #   Ignore packages that are filtered out
954 
        #
955 
        if ( defined $conf->{'packageFilter'} )
956 
        {
957 
            unless ( $pname =~ m~$conf->{'packageFilter'}~ )
958 
            {
959 
                $logger->verbose3("Filtering out: ${pname}");
960 
                $filteredCount++;
961 
                next;
962 
            }
963 
        }
964 
 
1038 dpurdie 965 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
966 
        {
6475 dpurdie 967 
            my $must_transfer;
968 
            my $existsRemote = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver});
969 
 
6148 dpurdie 970 
            #
971 
            #   Take care not to create an entry into $remotePkgList->{$pname}{$pver}
972 
            #   if it does not exist. Existence of {$pname}{$pver} is used later
973 
            #
7389 dpurdie 974 
            my $tmtime = undef;
6475 dpurdie 975 
            if ($existsRemote && exists ($remotePkgList->{$pname}{$pver}{time})) {
6148 dpurdie 976 
                $tmtime = $remotePkgList->{$pname}{$pver}{time};
977 
            }
5404 dpurdie 978 
            $packageVersionCount++;
1038 dpurdie 979 
 
980 
            # Package is present in both list
6475 dpurdie 981 
            my $localPackage = catdir( $conf->{'dpkg_archive'} , $pname, $pver );
982 
            my ($mtime, $mode) = Utils::mtime( catfile($localPackage, 'descpkg') );
1038 dpurdie 983 
            if ( $mtime == 0 )
984 
            {
985 
                # PackageVersion not in local archive (at least the descpkg file is not)
986 
                # Skip now - will pick it up later
987 
                $logger->verbose("Package not in dpkg_archive: $pname, $pver");
1048 dpurdie 988 
                $missingCount++;
1038 dpurdie 989 
                next;
990 
            }
991 
 
992 
            if ( $mode & 0222 )
993 
            {
994 
                # Descpkg file is writable
995 
                # Package may be in the process of being created
1048 dpurdie 996 
                # If the package has been writable for a long time, then
1038 dpurdie 997 
                # consider for transfer
998 
                my $age = $now - $mtime;
999 
                if ( $age < ($conf->{'writewindow '} || 600) )
1000 
                {
1001 
                    $logger->verbose("Package is writable: $pname, $pver, ", $now - $mtime);
1048 dpurdie 1002 
                    $writableCount++;
1038 dpurdie 1003 
                    next;
1004 
                }
1005 
            }
1006 
 
7389 dpurdie 1007 
            if (! $existsRemote ) {
1008 
                #
1009 
                #   Package does not exist in the remote, and is eligible for transfer
1010 
                #
1011 
                $logger->verbose("Package Needs to be transferred: $pname, $pver");
1012 
                $must_transfer = 1;
1013 
 
1014 
            } elsif ( defined $tmtime && ($mtime != $tmtime) ) {
1015 
                #
1016 
                #   Package exists in both source and target
1017 
                #   If the package-time is known, then ensure that they are the same
1018 
                #
6475 dpurdie 1019 
                $logger->verbose("Package Needs to be transferred: $pname, $pver, $mtime, $tmtime");
1020 
                $must_transfer = 1;
1021 
            }
7389 dpurdie 1022 
            else
1038 dpurdie 1023 
            {
6475 dpurdie 1024 
                #
1025 
                #   Package exists in both source and target
1026 
                #   Symlink test: Ensure symlinks are the same
1027 
                #
1028 
                my $localIsSymlink = -l $localPackage;
1029 
                my $remoteIsSymlink = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver}) && exists ($remotePkgList->{$pname}{$pver}{link});
1030 
 
1031 
                if ($remoteIsSymlink && $localIsSymlink) {
1032 
                    #
1033 
                    #   Both are symlinks - check that they address the same item
1034 
                    #
1035 
                    my $targetLink = $remotePkgList->{$pname}{$pver}{link};
1036 
                    $logger->verbose2("Package is symlink: $pname, $pver -> $targetLink");
1037 
 
1038 
                    my $lver = readlink( $localPackage );
1039 
                    if ( ! defined $lver ) {
1040 
                        $logger->warn("Can't resolve symlink: $pname, $pver");
1041 
                        next;
1042 
                    }
1043 
                    if ($targetLink ne $lver ) {
1044 
                        $logger->verbose("Package symlinks differ: $pname, $pver, $targetLink, $lver");
1045 
                        $must_transfer = 3;
1046 
                    }
1047 
 
1048 
                } elsif ($remoteIsSymlink || $localIsSymlink ) {
1049 
                    #
1050 
                    #   Only one is a symlink - force transfer
1051 
                    #
1052 
                    $logger->warn("Packages versions not both symlink: $pname, $pver, L:$remoteIsSymlink R:$localIsSymlink");
1053 
                    $must_transfer = 2;
1054 
                }
1055 
            }
1056 
 
1057 
            #
1058 
            #   If we are forcing a package transfer then flag it and also remove it from the
1059 
            #   RemotePkgList so that it will be transferred - even if its present on target
1060 
            #
1061 
            if ($must_transfer) {
1038 dpurdie 1062 
                # Package not present on target, or timestamps differ
1063 
                $needPkgList->{$pname}{$pver} = $pdata;
6475 dpurdie 1064 
                delete $RemotePkgList->{$pname}{$pver};
1048 dpurdie 1065 
                $needPkgListCount++;
1038 dpurdie 1066 
                next;
1067 
            }
1068 
        }
1069 
    }
1070 
 
1048 dpurdie 1071 
 
1038 dpurdie 1072 
    #
1073 
    #   Debug output only
1074 
    #   Display what we need to transfer
1075 
    #
1076 
    if ( $conf->{verbose} > 2 )
1077 
    {
1078 
        while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1079 
        {
1080 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
1081 
            {
1082 
                $logger->verbose("Need to transfer: $pname, $pver, $pdata");
1083 
            }
1084 
        }
1085 
    }
1048 dpurdie 1086 
    if ( $conf->{verbose}  )
1087 
    {
1088 
        $logger->verbose("Packages to transfer: $needPkgListCount");
1089 
        $logger->verbose("Packages to delete: $excessPkgListCount");
1090 
        $logger->verbose("Packages filtered out: $filteredCount");
1091 
        $logger->verbose("Packages missing: $missingCount");
1092 
        $logger->verbose("Packages still writable: $writableCount");
1093 
        $logger->verbose("Packages excluded: $excludeCount");
1094 
    }
1038 dpurdie 1095 
 
1096 
    #
5398 dpurdie 1097 
    #   Update stats
1098 
    #   At this point we are looking pretty good
1099 
    #
1100 
    $statistics{state} = 'OK';
5404 dpurdie 1101 
    $statistics{total} = $packageVersionCount;
5398 dpurdie 1102 
    $statistics{transfer} = $needPkgListCount;
1103 
    $statistics{delete} = $excessPkgListCount;
1104 
    $statistics{filtered} = $filteredCount;
1105 
    $statistics{missing} = $missingCount;
1106 
    $statistics{writable} = $writableCount;
1107 
    $statistics{excluded} = $excludeCount;
1108 
 
1109 
    #
1038 dpurdie 1110 
    #   Time to do the real work
1111 
    #   Transfer packages and delete excess packages
1112 
    #   Note: Perform the transfers first
1113 
    #         Limit the number of packages processed in one pass
1114 
    #
1115 
    my $txcount = $conf->{maxpackages};
1116 
 
1117 
    #
1118 
    #   Transfer packages that we have identified
1119 
    #
1120 
    while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1121 
    {
1122 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1123 
        {
7394 dpurdie 1124 
            tagForTransfer($pname, $pver);
1048 dpurdie 1125 
            $needPkgListCount--;
1038 dpurdie 1126 
        }
1127 
    }
1128 
 
1129 
    #
1130 
    #   Delete packages that have been identified as excess
1131 
    #
1132 
    while ( (my ($pname, $pvers)) = each %{$excessPkgList} )
1133 
    {
1134 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1135 
        {
7394 dpurdie 1136 
            tagForDelete ($pname, $pver, $pdata);
1137 
            $excessPkgListCount--;
1138 
        }
1139 
    }
1140 
 
1141 
    #
1142 
    #   Need to transmission remove tags for packages that don't need any more
1143 
    #   ie: Tags that have since been made unnessesary
1144 
    #
1145 
    my $taggedPackages = getTaggedPackages();
1146 
    if ($taggedPackages) {
1147 
        #
1148 
        #   Mark entries thay we still need
1149 
        #
1150 
        foreach my $pname ( keys %{$pkgList} )
1151 
        {
1152 
            foreach my $pver ( keys %{$pkgList->{$pname}} )
1038 dpurdie 1153 
            {
7394 dpurdie 1154 
                if (exists $taggedPackages->{$pname}{$pver}) {
1155 
                    $taggedPackages->{$pname}{$pver} = 1;
1156 
                }
1038 dpurdie 1157 
            }
7394 dpurdie 1158 
        }
1289 dpurdie 1159 
 
7394 dpurdie 1160 
        #
1161 
        #   Sweep out entries that we don't need any more
1162 
        foreach my $pname ( keys %{$taggedPackages} ) {
1163 
            foreach my $pver ( keys %{$taggedPackages->{$pname}} ) {
1164 
                unless ($taggedPackages->{$pname}{$pver}) {
1165 
$logger->verbose("Untag: $pname $pver");
1166 
                    unTagForTransfer($pname, $pver);
1167 
                }
1289 dpurdie 1168 
            }
1038 dpurdie 1169 
        }
7394 dpurdie 1170 
 
1038 dpurdie 1171 
    }
7394 dpurdie 1172 
 
1038 dpurdie 1173 
    #
1174 
    #   Send package list to the target
1175 
    #
1176 
    sendPackageList ($pkgList);
1040 dpurdie 1177 
 
1178 
    #
1179 
    #   On a successful transfer
1180 
    #       Force tag processing
1181 
    #       Set scan Mode to normal
1182 
    #
1183 
    $tagDirTime = 0;
1184 
    $releaseScanMode = 0;
1038 dpurdie 1185 
}
1186 
 
1187 
#-------------------------------------------------------------------------------
7394 dpurdie 1188 
# Function        : tagForTransfer
1189 
#
1190 
# Description     : Tag a package to be transferred
1191 
#
1192 
# Inputs          : $pname
1193 
#                   $pvers
1194 
#
1195 
# Returns         :
1196 
#
1197 
sub tagForTransfer
1198 
{
1199 
    my ($pname, $pver) = @_;
1200 
    my $tag = "$pname::$pver";
1201 
    my $myTag =  catfile($conf->{'tagdir'} , $tag);
1202 
    unless (-f $myTag ) {
1203 
        $logger->verbose2("tagForTransfer: $pname, $pver");
1204 
        Utils::TouchFile($conf, $myTag);
1205 
    }
1206 
    unlink 'DELD::' . $myTag;
1207 
    unlink 'DELF::' . $myTag;
1208 
}
1209 
 
1210 
#-------------------------------------------------------------------------------
1211 
# Function        : unTagForTransfer
1212 
#
1213 
# Description     : Un Tag a package to be transferred
1214 
#
1215 
# Inputs          : $pname
1216 
#                   $pvers
1217 
#
1218 
# Returns         :
1219 
#
1220 
sub unTagForTransfer
1221 
{
1222 
    my ($pname, $pver) = @_;
1223 
    my $tag = "$pname::$pver";
1224 
    my $myTag =  catfile($conf->{'tagdir'} , $tag);
1225 
    if (-f $myTag ) {
1226 
        $logger->verbose2("UnTagForTransfer: $pname, $pver");
1227 
        unlink($myTag);
1228 
    }
1229 
}
1230 
 
1231 
#-------------------------------------------------------------------------------
1232 
# Function        : tagForDelete
1233 
#
1234 
# Description     : Tag a package to be transferred
1235 
#                   Generate tags of the form
1236 
#                       DELD::pname::pver   - Delayed Delete
1237 
#                       DELF::pname::pver   - Forced Delete
1238 
#
1239 
# Inputs          : $pname
1240 
#                   $pver
1241 
#                   $pdata  - Type of delete
1242 
#
1243 
# Returns         :
1244 
#
1245 
sub tagForDelete
1246 
{
1247 
    my ($pname, $pver, $pdata) = @_;
1248 
    my $tag = "$pname::$pver";
1249 
    my $myTag =  catfile($conf->{'tagdir'} , $tag);
1250 
    my $delType = $pdata->{FORCEDELETE}  ? 'D' : 'F';
1251 
    my $myDelTag =  'DEL' . $delType . '::' . $myTag;
1252 
 
1253 
    unless (-f $myDelTag ) {
1254 
        $logger->verbose2("tagForDelete: $pname, $pver");
1255 
        Utils::TouchFile($conf, $myDelTag);
1256 
    }
1257 
    unlink $myTag;
1258 
}
1259 
 
1260 
#-------------------------------------------------------------------------------
1261 
# Function        : getTaggedPackages
1262 
#
1263 
# Description     : Determine the tagged packages
1264 
#
1265 
# Inputs          : None
1266 
#
1267 
# Returns         : Returns a pointer to a hash of tagged packages of the form
1268 
#
1269 
sub getTaggedPackages
1270 
{
1271 
    my $taggedPackages = {};
1272 
    foreach ( glob ("$conf->{'tagdir'}/*::*"))
1273 
    {
1274 
        next if m~/DEL.::~;
1275 
        m~.*/(.*)::(.*)~;
1276 
        $taggedPackages->{$1}{$2} = 0;
1277 
    }
1278 
    return $taggedPackages;
1279 
}
1280 
 
1281 
 
1282 
#-------------------------------------------------------------------------------
1038 dpurdie 1283 
# Function        : sendPackageList
1284 
#
1285 
# Description     : Transfer package list to the target
1286 
#
1287 
# Inputs          : $pkgList            - Ref to hash of package names and versions
1288 
#
1040 dpurdie 1289 
# Returns         : Nothing
1290 
#                   Don't really care about any errors from this process
1291 
#                   Its not essential
1038 dpurdie 1292 
#
1293 
sub sendPackageList
1294 
{
7389 dpurdie 1295 
    return if $isS3Target;
1296 
 
1038 dpurdie 1297 
    my ($pkgList) = @_;
1298 
    my ($fh, $filename) = tempfile( "/tmp/blat.$$.XXXX", SUFFIX => '.txt');
1299 
    $logger->verbose("sendPackageList:TmpFile: $filename");
6776 dpurdie 1300 
 
1301 
    return if $conf->{'noTransfers'};
1038 dpurdie 1302 
 
1303 
    #
1304 
    #   Create a temp file with data
1305 
    #
1306 
    foreach my $pname ( sort keys %{$pkgList} )
1307 
    {
1308 
        foreach my $pver ( sort keys %{$pkgList->{$pname}} )
1309 
        {
1310 
            print $fh "$pname/$pver\n";
1311 
        }
1312 
    }
1313 
    close $fh;
1314 
 
1315 
    #
1316 
    #   Transfer to target
1317 
    #   Create the process pipe to transfer the file
1318 
    #   gzip the file and pipe the result through a ssh session to the target machine
3515 dpurdie 1319 
    #   gzip -c filename |  ssh  ... "./receive_file filename"
1038 dpurdie 1320 
    #
1321 
    my $ph;
3515 dpurdie 1322 
    my $gzip_cmd = "$gzip --no-name -c \"$filename\"";
1040 dpurdie 1323 
    my $tgt_cmd = "$conf->{'bindir'}/receive_file \"ArchiveList\"";
3515 dpurdie 1324 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1325 
 
1326 
    $logger->verbose2("sendPackageList:gzip_cmd:$gzip_cmd");
1327 
    $logger->verbose2("sendPackageList:tgt_cmd:$tgt_cmd");
1328 
    $logger->verbose2("sendPackageList:ssh_cmd:$ssh_cmd");
1329 
 
1330 
    open ($ph, "$gzip_cmd | $ssh_cmd |");
1331 
    while ( <$ph> )
1332 
    {
1333 
        chomp;
1334 
        $logger->verbose2("sendPackageList:Data: $_");
1335 
    }
1336 
    close ($ph);
3515 dpurdie 1337 
    unlink $filename;
1038 dpurdie 1338 
    $logger->verbose("sendPackageList:End: $?");
3515 dpurdie 1339 
    LogTxError ($?);
1038 dpurdie 1340 
}
1341 
 
1342 
 
1343 
#-------------------------------------------------------------------------------
1344 
# Function        : getPkgList
1345 
#
1346 
# Description     : Determine a set of package versions within the list
1347 
#                   of provided releases
1348 
#
1349 
# Inputs          : @rlist              - A list of releases to examine
1350 
#
1351 
# Returns         : Ref to a hask of package versions
1352 
#
1353 
sub getPkgList
1354 
{
1355 
    my %pdata;
1356 
    my $RM_DB;
1357 
    connectRM(\$RM_DB);
1358 
    $logger->verbose("getPkgList");
1359 
 
1360 
    #
1361 
    #   Determine the releases that are in this project
1362 
    #   Build up an sql query
1363 
    #
6776 dpurdie 1364 
    my $m_rlist = join ',', @_;
1048 dpurdie 1365 
    my $m_sqlstr = "SELECT DISTINCT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.IS_DEPLOYABLE" .
1038 dpurdie 1366 
                    " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
6776 dpurdie 1367 
                    " WHERE ( RTAG_ID in ($m_rlist) ) AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID" .
1038 dpurdie 1368 
                    " ORDER by PKG_NAME DESC";
1369 
    $logger->verbose3("getPkgList:Sql:$m_sqlstr");
1370 
 
1371 
    my $sth = $RM_DB->prepare($m_sqlstr);
1372 
    if ( defined($sth) )
1373 
    {
1374 
        if ( $sth->execute( ) )
1375 
        {
1376 
            if ( $sth->rows )
1377 
            {
1378 
                while (my @row = $sth->fetchrow_array )
1379 
                {
1380 
                    $logger->verbose2("getPkgList:Data:@row");
1381 
                    $pdata{$row[1]}{$row[2]} = 1;
1382 
                }
1383 
            }
1384 
            $sth->finish();
1385 
        }
1386 
    }
1387 
    else
1388 
    {
1389 
        $logger->warn("getPkgList: SQL Prepare failure");
1390 
    }
1050 dpurdie 1391 
 
1392 
   disconnectRM(\$RM_DB);
1038 dpurdie 1393 
   return \%pdata;
1394 
}
1395 
 
1396 
 
1397 
#-------------------------------------------------------------------------------
1398 
# Function        : getReleaseList
1399 
#
1400 
# Description     : Determine the list of releases to be proccessed
1040 dpurdie 1401 
#                   From:
1402 
#                       Convert projects to a list of releases
1403 
#                       Configured list of releases
1038 dpurdie 1404 
#
1405 
# Inputs          : None
1406 
#
1407 
# Returns         : A list of releases to be processed
1408 
#
1409 
sub getReleaseList
1410 
{
1411 
    my $RM_DB;
1412 
    my %rlist;
1048 dpurdie 1413 
    my $m_sqlstr;
1038 dpurdie 1414 
    $logger->verbose("getReleaseList");
1415 
 
1416 
    #
1040 dpurdie 1417 
    #   Cache data
1418 
    #   Only for one cycle of the main loop
1419 
    #
1420 
    if ( exists $releaseData{getReleaseList} )
1421 
    {
1422 
        $logger->verbose3("getReleaseList:Cache hit");
1423 
        return @{$releaseData{getReleaseList}};
1424 
    }
1425 
 
1426 
    #
1048 dpurdie 1427 
    #   All projects
1038 dpurdie 1428 
    #
1048 dpurdie 1429 
    if ( $conf->{'allProjects'} )
1038 dpurdie 1430 
    {
1048 dpurdie 1431 
        $m_sqlstr = "SELECT rt.RTAG_ID" .
1432 
                    " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
7539 dpurdie 1433 
                    " WHERE rt.OFFICIAL != 'A'".
1434 
                    "   AND rt.OFFICIAL != 'S'";
1050 dpurdie 1435 
                    #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1436 
    }
1437 
    else
1438 
    {
1038 dpurdie 1439 
        #
1048 dpurdie 1440 
        #   Convert list of projects into a list of releases
1038 dpurdie 1441 
        #
6776 dpurdie 1442 
        if ( @projectList )
1048 dpurdie 1443 
        {
1444 
            #
1445 
            #   Determine the releases that are in this project
1446 
            #   Build up an sql query
1447 
            #
6776 dpurdie 1448 
            my $m_plist = join ',', @projectList;
1048 dpurdie 1449 
            $m_sqlstr = "SELECT rt.RTAG_ID" .
1450 
                        " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
7539 dpurdie 1451 
                        " WHERE ( PROJ_ID in ( $m_plist) )" .
1452 
                        "   AND rt.OFFICIAL != 'A'" .
1453 
                        "   AND rt.OFFICIAL != 'S'";
5300 dpurdie 1454 
                        #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1455 
        }
1456 
    }
1038 dpurdie 1457 
 
1048 dpurdie 1458 
    if ( defined $m_sqlstr )
1459 
    {
1038 dpurdie 1460 
        $logger->verbose3("getReleaseList:Sql:$m_sqlstr");
1048 dpurdie 1461 
        connectRM(\$RM_DB);
1038 dpurdie 1462 
        my $sth = $RM_DB->prepare($m_sqlstr);
1463 
        if ( defined($sth) )
1464 
        {
1465 
            if ( $sth->execute( ) )
1466 
            {
1467 
                if ( $sth->rows )
1468 
                {
1469 
                    while (my @row = $sth->fetchrow_array )
1470 
                    {
1471 
                        $logger->verbose2("getReleaseList:Data:@row");
1472 
                        $rlist{$row[0]} = 1;
1473 
                    }
1474 
                }
1475 
                $sth->finish();
6776 dpurdie 1476 
            } else {
1477 
                $logger->warn("getReleaseList: SQL Execute failure");
1038 dpurdie 1478 
            }
1479 
        }
1480 
        else
1481 
        {
1482 
            $logger->warn("getReleaseList: SQL Prepare failure");
1483 
        }
1050 dpurdie 1484 
        disconnectRM(\$RM_DB);
1038 dpurdie 1485 
    }
1486 
 
1487 
    #
1488 
    #   Add in the user specified list of releases
1489 
    #
6776 dpurdie 1490 
    $rlist{$_} = 1 foreach(@releaseList);
1038 dpurdie 1491 
 
1492 
    #
1493 
    #   Sort for pretty display only
1494 
    #
1040 dpurdie 1495 
    @{$releaseData{getReleaseList}} = sort {$a <=> $b} keys %rlist;
1496 
 
1497 
    return @{$releaseData{getReleaseList}};
1038 dpurdie 1498 
}
1499 
 
1040 dpurdie 1500 
#-------------------------------------------------------------------------------
3846 dpurdie 1501 
# Function        : getPackageVersions
1502 
#
1503 
# Description     : Get the list of package-versions available in the package
1504 
#                   store.
1505 
#
1506 
# Inputs          : pkgName             - The package name
1507 
#
1508 
# Returns         : Array of versions
1509 
#
1510 
sub getPackageVersions
1511 
{
1512 
    my ($pkgName) = @_;
1513 
    my @versionList;
1514 
 
1515 
    my $pkgDir = catfile($conf->{'dpkg_archive'} , $pkgName );
1516 
    my $dh;
1517 
 
1518 
    unless (opendir($dh, $pkgDir))
1519 
    {
1520 
        $logger->warn ("Can't opendir $pkgDir: $!");
1521 
        return @versionList;
1522 
    }
1523 
 
1524 
    #
1525 
    #   Process each entry
1526 
    #   Ignore those that start with a .
1527 
    #
1528 
    while (my $version = readdir($dh) )
1529 
    {
1530 
        next if ( $version =~ m~^\.~ );
1531 
        my $file = catfile($pkgDir, $version);
1532 
 
1533 
        next unless ( -d $file );
1534 
 
1535 
        push @versionList, $version;
1536 
        $logger->verbose3("getPackageVersions: $pkgName, $version");
1537 
    }
1538 
    closedir $dh;
1539 
    return @versionList;
1540 
}
1541 
 
1542 
#-------------------------------------------------------------------------------
4456 dpurdie 1543 
# Function        : getArchiveList
1544 
#
1545 
# Description     : Get the entire set of package versions in the archive
1546 
#
1547 
# Inputs          :
1548 
#
6475 dpurdie 1549 
# Returns         : Ref to a hash of package versions
4456 dpurdie 1550 
#
1551 
sub getArchiveList
1552 
{
1553 
    my $pkgDir = $conf->{'dpkg_archive'};
1554 
    my %archiveList;
1555 
    my $dh;
1556 
    my @pkgList;
1557 
 
1558 
    unless (opendir($dh, $pkgDir))
1559 
    {
1560 
        $logger->warn ("Can't opendir $pkgDir: $!");
1561 
        return \%archiveList;
1562 
    }
1563 
 
1564 
    #
1565 
    #   Process each entry
1566 
    #   Ignore those that start with a .
1567 
    #   Ignore files
1568 
    #
1569 
    while (my $pkgName = readdir($dh) )
1570 
    {
1571 
        next if ( $pkgName =~ m~^\.~ );
1572 
        my $file = catfile($pkgDir, $pkgName);
1573 
 
1574 
        next unless ( -d $file );
1575 
        $logger->verbose3("getArchiveList: $pkgName");
1576 
        push @pkgList, $pkgName;
1577 
    }
1578 
    closedir $dh;
1579 
 
1580 
    #   Now get the package versions
1581 
    #       Sort for pretty display
1582 
    foreach my $pname (sort @pkgList)
1583 
    {
1584 
        foreach my $pver (getPackageVersions($pname))
1585 
        {
1586 
            $archiveList{$pname}{$pver} = 1;
1587 
        }
1588 
    }
1589 
 
1590 
    return \%archiveList;
1591 
}
1592 
 
1593 
#-------------------------------------------------------------------------------
6320 dpurdie 1594 
# Function        : getBlatBin
1595 
#
1596 
# Description     : Get the list of files that should be in the targetbin directory
1597 
#
1598 
# Inputs          : Nothing
1599 
#
1600 
# Returns         : A hash of data
1601 
#
1602 
sub getBlatBin
1603 
{
1604 
    my $data;
1605 
    $logger->verbose("getBlatBin: $targetBinDir");
1606 
    if (opendir(DIR, $targetBinDir ) ) {
1607 
        my @vlist = readdir(DIR);
1608 
        closedir DIR;
1609 
 
1610 
        foreach my $vname ( sort @vlist )
1611 
        {
1612 
            next if ( $vname eq '.' );
1613 
            next if ( $vname eq '..' );
1614 
            next unless ( -f "$targetBinDir/$vname" );
1615 
 
1616 
            if (open FILE, "$targetBinDir/$vname") {
1617 
                $data->{$vname} = Digest::MD5->new->addfile(*FILE)->hexdigest;
1618 
                close (FILE);
1619 
            }
1620 
        }
1621 
    } else {
1622 
        $logger->warn("BlatBin Not Found: $targetBinDir");
1623 
    }
1624 
    return $data;
1625 
}
1626 
 
1627 
 
1628 
#-------------------------------------------------------------------------------
1040 dpurdie 1629 
# Function        : maintainTagList
1630 
#
1631 
# Description     : Maintain a data structure for the maintenance of the
1632 
#                   tags directory
1633 
#
1634 
# Inputs          : None
1635 
#
1636 
# Returns         : Nothing
1637 
#
1638 
sub maintainTagList
1639 
{
1640 
    #
1641 
    #   Time to perform the scan
1642 
    #   Will do at startup and every time period there after
1643 
    #
6779 dpurdie 1644 
    return unless ( $now > ($lastTagListUpdate + $conf->{tagListUpdate} ));
1040 dpurdie 1645 
    $logger->verbose("maintainTagList");
6779 dpurdie 1646 
    $lastTagListUpdate = $now;
1038 dpurdie 1647 
 
1040 dpurdie 1648 
    #
1649 
    #   Get list of things
1650 
    #
1651 
    my %config;
7394 dpurdie 1652 
 
1653 
    #
1654 
    #   Is Tag Processing active
1655 
    #   Can configure blat to disable tag sync
1656 
    #
1657 
    if ( $conf->{'tagMaxPackages'} > 0 )
4457 dpurdie 1658 
    {
7469 dpurdie 1659 
        if ($conf->{'allNewPkgs'} ) {
1660 
            $config{allNewPkgs} = 1
1661 
        }
7394 dpurdie 1662 
 
1663 
        if ($conf->{'allArchive'} )
1664 
        {
1665 
            $config{allArchive} = 1
1666 
        }
1667 
        elsif ($conf->{'allProjects'} )
1668 
        {
1669 
            $config{allProjects} = 1;
1670 
        }
1671 
        else
1672 
        {
1673 
            %{$config{projects}} = map { $_ => 1 } @projectList;
1674 
            %{$config{releases}} = map { $_ => 1 } getReleaseList();
1675 
        }
1676 
    } else {
1677 
        $config{disableTagTx} = 1
4457 dpurdie 1678 
    }
1040 dpurdie 1679 
 
1680 
    #
1681 
    #   Save data
1682 
    #
1683 
    my $dump =  Data::Dumper->new([\%config], [qw(*config)]);
1684 
#print $dump->Dump;
1685 
#$dump->Reset;
1686 
 
1687 
    #
1688 
    #   Save config data
1689 
    #
1690 
    my $conf_file = catfile( $conf->{'tagdir'},'.config' );
1691 
    $logger->verbose3("maintainTagList: Writting $conf_file");
1692 
 
1693 
    my $fh;
1694 
    open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
1695 
    print $fh $dump->Dump;
1696 
    close $fh;
1697 
}
1698 
 
1699 
 
1038 dpurdie 1700 
#-------------------------------------------------------------------------------
1701 
# Function        : processTags
1702 
#
1703 
# Description     : Process tags and send marked package versions to the target
1704 
#                       Determine if new tags are present
1705 
#                       Process each tag
7394 dpurdie 1706 
#
1707 
#                       Two types of tag
1708 
#                           Transfer Requests
1709 
#                           Delete Request
1710 
#                       Send packages before deleting packages
1038 dpurdie 1711 
#
1712 
# Inputs          : None
1713 
#
1714 
# Returns         : Nothing
1715 
#
1716 
sub processTags
1717 
{
6779 dpurdie 1718 
 
1038 dpurdie 1719 
    #
1720 
    #   Determine if new tags are present by examining the time
1721 
    #   that the directory was last modified.
1722 
    #
1723 
    #   Allow for a forced scan to catch packages that did not transfer
1724 
    #   on the first attempt
1725 
    #
5398 dpurdie 1726 
    my $tagCount = 0;
7394 dpurdie 1727 
    my $delCount = 0;
1728 
 
1038 dpurdie 1729 
    my ($mtime) = Utils::mtime($conf->{'tagdir'} );
1730 
    if ( ($mtime > $tagDirTime) || ($now > ($lastDirScan + $conf->{'forcedirscan'})) )
1731 
    {
1042 dpurdie 1732 
        $logger->verbose2("processTags: ",$conf->{'tagdir'}, $mtime - $tagDirTime, $now - $lastDirScan);
1038 dpurdie 1733 
        $tagDirTime = $mtime;
1734 
        $lastDirScan = $now;
6779 dpurdie 1735 
        my $txcount = $conf->{'tagMaxPackages'};
1038 dpurdie 1736 
 
1737 
        my $dh;
1738 
        unless (opendir($dh, $conf->{'tagdir'}))
1739 
        {
1740 
            $logger->warn ("can't opendir $conf->{'tagdir'}: $!");
1741 
            return;
1742 
        }
1743 
 
1744 
        #
1745 
        #   Process each entry
1746 
        #   Ignore those that start with a .
7460 dpurdie 1747 
        #   Attempt to keep the entries in time of creation order.
1038 dpurdie 1748 
        #
7460 dpurdie 1749 
        my @tagPkgList;
7394 dpurdie 1750 
        my %deleteTags;
7460 dpurdie 1751 
        my @sortedFiles = sort {(stat($conf->{'tagdir'} .'/'. $a))[10] <=> (stat($conf->{'tagdir'} .'/'. $b))[10]} readdir($dh);
1752 
        closedir $dh;
1753 
 
1754 
        foreach my $tag (@sortedFiles)
1038 dpurdie 1755 
        {
1756 
            next if ( $tag =~ m~^\.~ );
1757 
            my $file = "$conf->{'tagdir'}/$tag";
1042 dpurdie 1758 
            $logger->verbose3("processTags: $file");
1759 
 
1038 dpurdie 1760 
            next unless ( -f $file );
1761 
            next if ( $tag  eq 'ReleaseList' );
1762 
 
7394 dpurdie 1763 
            if ( $tag  =~ m~^DEL(.)::(.+)::(.+)~) {
1764 
                $deleteTags {$2}{$3}{file} = $file;
1765 
                $deleteTags {$2}{$3}{mode} = $1 eq 'F' ? 1 : 0;
1766 
                $delCount++;
1767 
            }
1768 
 
1038 dpurdie 1769 
            if ( $tag =~ m~(.+)::(.+)~  )
1770 
            {
7460 dpurdie 1771 
                push @tagPkgList, join($;,  $1, $2, $file);
5398 dpurdie 1772 
                $tagCount++;
6779 dpurdie 1773 
            }
1774 
        }
1775 
        $statistics{tagCount} = $tagCount;
7394 dpurdie 1776 
        $statistics{tagDelCount} = $delCount;
6098 dpurdie 1777 
 
6779 dpurdie 1778 
        #
7394 dpurdie 1779 
        #   Process delete requests after all transfers have occured
7469 dpurdie 1780 
        #
1781 
        my $showDel = $delCount;
1782 
        my $showSend = $tagCount;
1783 
 
7394 dpurdie 1784 
        unless ($tagCount) {
1785 
            delete_pkgs:
1786 
            while ( (my ($pname, $pvers)) = each %deleteTags )
1787 
            {
1788 
                while ( (my ($pver, $pdata) ) = each %{$pvers} )
1789 
                {
1790 
                    if ( --$txcount <= 0 )
1791 
                    {
1792 
                        $tagDirTime = 0;
1793 
                        last delete_pkgs;
1794 
                    }
1795 
 
1796 
                    if ( readConfig() )
1797 
                    {
1798 
                        $logger->warn("Config file changed");
1799 
                        $txcount = 0;
1800 
                        $tagDirTime = 0;
1801 
                        last delete_pkgs;
1802 
                    }
1803 
 
1804 
                    deletePackage ($pname, $pver, $pdata->{mode});
1805 
                    unlink $pdata->{file};
1806 
                    $delCount--;
1807 
                    reapChildren();
7460 dpurdie 1808 
                    Utils::resetWedge();
7394 dpurdie 1809 
                }
1810 
            }
1811 
        }
1812 
 
1813 
        #
6779 dpurdie 1814 
        #   Process the packages located in the tags area
7460 dpurdie 1815 
        #   Have attempted to keep them in creation order
6779 dpurdie 1816 
        #
7539 dpurdie 1817 
        my $notSent = 0;
6779 dpurdie 1818 
        send_tags:
7460 dpurdie 1819 
        foreach my $entry ( @tagPkgList )
6779 dpurdie 1820 
        {
7460 dpurdie 1821 
            my ($package, $version, $file) = split ($;, $entry);
1822 
            if ( --$txcount <= 0 )
6779 dpurdie 1823 
            {
7460 dpurdie 1824 
                $tagDirTime = 0;
1825 
                last send_tags;
1826 
            }
6779 dpurdie 1827 
 
7460 dpurdie 1828 
            if ( readConfig() )
1829 
            {
1830 
                $logger->warn("Config file changed");
1831 
                $txcount = 0;
1832 
                $tagDirTime = 0;
1833 
                last send_tags;
1834 
            }
6779 dpurdie 1835 
 
7389 dpurdie 1836 
#               #
1837 
#               #   Don't transfer 'extra' packages
1838 
#               #   Removed. It was casuing a tarZip to be triggered, but never transferred
1839 
#               #
1840 
#               if (exists ($extraPkgs->{$package}) )
1841 
#               {
1842 
#                   $logger->warn ("Delete excess package tag: $package::$version");
1843 
#                   unlink $file;
1844 
#
1845 
#               } else
7469 dpurdie 1846 
            my ($txDone, $workDone) = transferPackage( $package, $version );
1847 
            $txcount++ unless $workDone;
1848 
            if ($txDone ) {
7460 dpurdie 1849 
                unlink $file;
1850 
            }
1851 
            else
1852 
            {
7539 dpurdie 1853 
                $notSent++;
7460 dpurdie 1854 
                if ($conf->{'tagage'} > 0) {
1855 
                    my ($mtime) = Utils::mtime( $file );
1856 
                    if ( $now - $mtime > $conf->{'tagage'} )
1857 
                    {
1858 
                        $logger->warn ("Delete unsatisfied tag: $package::$version after $conf->{'tagage'}" );
1859 
                        unlink $file;
1860 
                        $statistics{staleTags}++;
1038 dpurdie 1861 
                    }
1862 
                }
7460 dpurdie 1863 
            }
6779 dpurdie 1864 
 
7460 dpurdie 1865 
            $tagCount--;
1866 
            reapChildren();
1867 
            Utils::resetWedge();
1038 dpurdie 1868 
        }
7469 dpurdie 1869 
 
1870 
        # Nice output
1871 
        if ($showSend) {
7539 dpurdie 1872 
            $logger->warn("Max tag transfer count exceeded: $notSent transfer remaining");
7469 dpurdie 1873 
            $logger->warn("Max tag transfer count exceeded: $delCount deletion remaining");
1874 
        }
1875 
        elsif ($showDel) {
1876 
            $logger->warn("Max tag transfer count exceeded: $delCount deletion remaining");
1877 
        }
1038 dpurdie 1878 
    }
1879 
}
1880 
 
1881 
#-------------------------------------------------------------------------------
6320 dpurdie 1882 
# Function        : transferBlatBin
1883 
#
1884 
# Description     : Transfer any of the Blat Bin files that are out of date
1885 
#                   on the target
1886 
#
1887 
# Inputs          : $fileHash       - A hash whose files are those that need
1888 
#                                     to be updated
1889 
#
1890 
# Returns         :
1891 
#
1892 
sub transferBlatBin
1893 
{
1894 
    my ($hash) = @_;
1895 
    $logger->verbose("transferBlatBin");
6776 dpurdie 1896 
 
1897 
    return if $conf->{'noTransfers'};
1898 
 
6320 dpurdie 1899 
    foreach my $file ( sort keys %{$hash})
1900 
    {
1901 
        $logger->logmsg("transferBlatBin: $file");
1902 
 
1903 
        #
1904 
        #   Transfer one file using only 'ssh'
1905 
        #   Create the target directory on the fly
1906 
        #   Manipulate file permissions
1907 
        #   Report errors
1908 
 
1909 
        my $tar_cmd = "cat \"$targetBinDir/$file\"";
6475 dpurdie 1910 
        my $tgt_cmd = "mkdir -p ~/bin && if [ -f \"~/bin/$file\" ] ; then chmod +x+w \"~/bin/$file\"; fi && cat > \"~/bin/$file\" && chmod +x-w \"~/bin/$file\" || exit 1";
6320 dpurdie 1911 
        my $ssh_cmd = sshCmd($tgt_cmd);
1912 
        my $cat_cmd =
1913 
 
1914 
        $logger->verbose2("transferBlatBin:tar_cmd:$tar_cmd");
1915 
        $logger->verbose2("transferBlatBin:tgt_cmd:$tgt_cmd");
1916 
        $logger->verbose2("transferBlatBin:ssh_cmd:$ssh_cmd");
1917 
 
1918 
        my $ph;
1919 
        open ($ph, "$tar_cmd | $ssh_cmd |");
1920 
        while ( <$ph> )
1921 
        {
1922 
            chomp;
1923 
            $logger->verbose2("transferBlatBin:Data: $_");
1924 
        }
1925 
        close ($ph);
1926 
        $logger->verbose("transferBlatBin:End: $?");
1927 
 
1928 
        if ( $? != 0 )
1929 
        {
1930 
            $logger->warn("transferBlatBin:Transfer Error: $file, $?");
1931 
        }
1932 
        LogTxError ($?);
1933 
    }
1934 
}
1935 
 
7394 dpurdie 1936 
#-------------------------------------------------------------------------------
1937 
# Function        : calcZipRequests
1938 
#
1939 
# Description     : Determine the number of packages that I need that have
1940 
#                   outstanding ZIP requests
1941 
#
1942 
#                   Purpose is to limit the number of ZIP requests that are
1943 
#                   outstanding at any one time to reduce disc space
1944 
#
1945 
#                   ie: Iff there 1000 outstanding transfers, we don't need to zip all
1946 
#                   of the packages right now.
1947 
#
1948 
# Inputs          :
1949 
#
1950 
# Returns         :
1951 
#
1952 
#
1953 
sub calcZipRequests
1954 
{
1955 
    my $zipRequests = 0;
6320 dpurdie 1956 
 
7394 dpurdie 1957 
    $conf->{'tagdir'} =~ m~^(.*)/~;
1958 
    my $tagRoot = $1;
1959 
 
1960 
    my $dh;
1961 
    if ( opendir($dh, $conf->{'tagdir'}) )
1962 
    {
1963 
        while (my $tag = readdir($dh) )
1964 
        {
1965 
            next if ( $tag =~ m~^\.~ );
1966 
            my $file = "$conf->{'tagdir'}/$tag";
7539 dpurdie 1967 
#            $logger->verbose3("calcZipRequests: $file");
7394 dpurdie 1968 
 
1969 
            next unless ( -f $file );
1970 
            next if ( $tag  eq 'ReleaseList' );
1971 
            next if ( $tag =~ m~^DEL(.)::~);
1972 
 
1973 
            my $zipTag = catfile($tagRoot, 'tarZip', $tag);
1974 
            if (-f $zipTag ) {
1975 
                $zipRequests++;
1976 
            }
1977 
        }
1978 
        closedir $dh;
1979 
    }
1980 
    $logger->verbose("zipRequests: $zipRequests");
1981 
    return $zipRequests;
1982 
}
1983 
 
1984 
 
6320 dpurdie 1985 
#-------------------------------------------------------------------------------
1038 dpurdie 1986 
# Function        : transferPackage
1987 
#
1988 
# Description     : Transfer specified package to target system
6475 dpurdie 1989 
#                   If a symlink, then a symlink will be transferred
1038 dpurdie 1990 
#
1991 
# Inputs          : $pname          - Name of the package
1992 
#                   $pver           - Package version
1993 
#
7469 dpurdie 1994 
# Returns         : Two items
1995 
#                       txDone          - True package transferred. False Not transferred
1996 
#                       workDone        - True: work done. Flase: No work done
1997 
#
1998 
# true    - Package transferred
1038 dpurdie 1999 
#                   false   - Package not transferred
7460 dpurdie 2000 
#
1038 dpurdie 2001 
#
7460 dpurdie 2002 
#                   PackageExcluded         - Assume that its been transferred
2003 
#                   PackageAtTarget         - Package known to be on the target
2004 
#                   PackageNotInArchive     - Package not found in dpkg_archive
2005 
#                   PackageZipRequested     - Requested a Zipped version of the package
2006 
#                   PackageZipNotRequested  - Need a Zipped version, but I have too many requests outstanding
2007 
#                   PackageTransferOK       - Package has been transferred
2008 
#                   PackageTransferError    - Error in the package transfer
2009 
#
2010 
#
2011 
#
1038 dpurdie 2012 
sub transferPackage
2013 
{
6475 dpurdie 2014 
    my ($pname, $pver ) = @_;
1038 dpurdie 2015 
    my $rv = 0;
6776 dpurdie 2016 
    my $cmdRv = 0;
7389 dpurdie 2017 
    $logger->verbose("Enter transferPackage: @_");
6148 dpurdie 2018 
    my $startTime = time;
1038 dpurdie 2019 
 
2020 
    #
1040 dpurdie 2021 
    #   Do not transfer excluded files
2022 
    #
2023 
    if ( exists $excludePkgs->{$pname} )
2024 
    {
1048 dpurdie 2025 
        $logger->warn("transferPackage: Excluded package not transferred: $pname, $pver");
7469 dpurdie 2026 
        return 1, 0;
1040 dpurdie 2027 
    }
1048 dpurdie 2028 
 
1040 dpurdie 2029 
    #
1048 dpurdie 2030 
    #   Apply package filter
2031 
    #
2032 
    if ( defined $conf->{'packageFilter'} )
2033 
    {
2034 
        unless ( $pname =~ m~$conf->{'packageFilter'}~ )
2035 
        {
2036 
            $logger->warn("transferPackage: Filtered out package not transferred: $pname, $pver");
7469 dpurdie 2037 
            return 1, 0;
1048 dpurdie 2038 
        }
2039 
    }
2040 
 
2041 
    #
6148 dpurdie 2042 
    #   If its known to be in the target archive, then we don't need to transfer it again
2043 
    #       It may have been transferred in this cycle
2044 
    #       It may have been in the archive anyway
1038 dpurdie 2045 
    #
6148 dpurdie 2046 
    if ( exists($RemotePkgList->{$pname}) && exists ($RemotePkgList->{$pname}{$pver})) {
2047 
        $logger->verbose("transferPackage: Already in archive");
6320 dpurdie 2048 
        #$logger->logmsg("transferPackage: $pname, $pver : Already in archive");
7469 dpurdie 2049 
        return 1, 0;
1038 dpurdie 2050 
    }
2051 
 
6475 dpurdie 2052 
    my $sdir = catfile( $conf->{'dpkg_archive'} , $pname );
2053 
    my $sfile = catfile( $sdir, $pver );
1038 dpurdie 2054 
    unless ( -d $sfile )
2055 
    {
2056 
        $logger->warn("transferPackage:Package not found: $pname, $pver");
7469 dpurdie 2057 
        return 0, 0;
1038 dpurdie 2058 
    }
2059 
 
7387 dpurdie 2060 
    my $tzdir = catfile( $conf->{'dpkg_archive'} , '.dpkg_archive', 'tarStore' );
2061 
    my $tzfile = $pname . '__' . $pver . '.tgz';
2062 
    my $tzpath = catfile($tzdir, $tzfile);
2063 
    unless (-f $tzpath) {
7394 dpurdie 2064 
        $logger->verbose("transferPackage: tarZip not found - $tzfile");
7387 dpurdie 2065 
 
2066 
        $conf->{'tagdir'} =~ m~^(.*)/~;
2067 
        my $tagRoot = $1;
2068 
        my $tag = "$pname::$pver";
7389 dpurdie 2069 
        my $zipTag = catfile($tagRoot, 'tarZip', $tag);
2070 
        my $myTag =  catfile($conf->{'tagdir'} , $tag);
2071 
 
7460 dpurdie 2072 
        # Ensure I have an outstanding request, so that the tarZip process can notify me
7394 dpurdie 2073 
        Utils::TouchFile($conf, $myTag) unless -f $myTag;
7389 dpurdie 2074 
 
7394 dpurdie 2075 
        unless (-f $zipTag) {
2076 
            if (calcZipRequests() < $conf->{maxTarZips} ) {
7460 dpurdie 2077 
                $logger->logmsg("transferPackage. Request Zip: @_");
7394 dpurdie 2078 
                Utils::TouchFile($conf, $zipTag);
2079 
            } else {
2080 
                $logger->verbose("transferPackage: Max outstanding tarZip Requests");
2081 
            }
2082 
        }
7469 dpurdie 2083 
        return 0, 0;
7387 dpurdie 2084 
    }
2085 
 
2086 
 
6475 dpurdie 2087 
    ###########################################################################
2088 
    #   Transfer the package / symlink
1038 dpurdie 2089 
    #
7389 dpurdie 2090 
    $logger->logmsg("transferPackage: @_");
2091 
    my $tzfsize = -s $tzpath;
7387 dpurdie 2092 
    if ($isS3Target) {
2093 
        $cmdRv = transferPackageS3($tzdir, $tzfile, $pname, $pver);
2094 
    } else {
2095 
        $cmdRv = transferPackageSsh($tzdir, $tzfile, $sfile, $pname, $pver);
2096 
    }
2097 
 
2098 
    #
7389 dpurdie 2099 
    #   Display the size of the package (tarZipped)
7387 dpurdie 2100 
    #       Diagnostic use
2101 
    #
2102 
    if ($conf->{txdetail}) {
7389 dpurdie 2103 
        my $size = sprintf "%.3f", $tzfsize / 1024 / 1024 / 1024 ;
7387 dpurdie 2104 
        my $duration = time - $startTime;
2105 
        $logger->logmsg("transferPackage: Stats: $pname, $pver, $size Gb, $duration Secs");
2106 
    }
2107 
 
2108 
    if ( $cmdRv == 0 ) {
2109 
        #
2110 
        #   Mark has having been transferred in the current cycle
2111 
        #
2112 
        $RemotePkgList->{$pname}{$pver}{transferred} = 1;
2113 
        $rv = 1;
2114 
        $statistics{txCount}++;
2115 
 
2116 
    } else {
2117 
        $logger->warn("transferPackage:Transfer Error: $pname, $pver, $?");
2118 
    }
2119 
 
2120 
    LogTxError ($?);
7469 dpurdie 2121 
    return $rv, 1;
7387 dpurdie 2122 
}
2123 
 
2124 
#-------------------------------------------------------------------------------
2125 
# Function        : transferPackageSsh
2126 
#
2127 
# Description     : Transfer a package via an ssh connection
2128 
#
2129 
# Inputs          : $tzdir  - Directory that contains the tarZip file
2130 
#                   $tzname - Name of tarZip File
2131 
#                   $sfile  - Full path to the source file
2132 
#                   $pname  - Package Name
2133 
#                   $pver   - Package Version
2134 
#
2135 
# Returns         : Result Code
2136 
#                   0   - Transfer OK
2137 
#                   <0  - Skip transfer
2138 
#                   >0  - Command error code
2139 
#
2140 
sub transferPackageSsh
2141 
{
2142 
    my ($tzdir, $tzname, $sfile, $pname, $pver) = @_;
6475 dpurdie 2143 
    my $tgt_cmd;
2144 
    my $ssh_cmd;
7387 dpurdie 2145 
    my $cmdRv = 0;
2146 
    my $tzfile = catfile($tzdir, $tzname);
2147 
 
6475 dpurdie 2148 
    if (-l $sfile) {
1038 dpurdie 2149 
 
6475 dpurdie 2150 
        #
2151 
        #   Determine the value of the symlink
7387 dpurdie 2152 
        #   Only support simple symlinks - that are in the same directory
6475 dpurdie 2153 
        #
2154 
        my $lver = readlink( $sfile );
2155 
        if ( ! defined $lver ) {
2156 
            $logger->warn("Can't resolve symlink: $pname, $pver");
7387 dpurdie 2157 
            return -1;
6475 dpurdie 2158 
        }
2159 
 
2160 
        if ( $lver =~ m ~/~ ) {
2161 
            $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
7387 dpurdie 2162 
            return -1;
6475 dpurdie 2163 
        }
2164 
 
2165 
        $tgt_cmd = "$conf->{'bindir'}/receive_symlink \"$pname\" \"$pver\" \"$lver\"";
2166 
        $ssh_cmd = sshCmd($tgt_cmd);
2167 
 
2168 
    } else {
2169 
        #
2170 
        #   Create the process pipe to transfer the package
7387 dpurdie 2171 
        #   Pipe the tarZip of the package through a ssh session to the target machine
2172 
        #   cat $tzpath | ssh  ... "./receive_package pname pver"
6475 dpurdie 2173 
        #
2174 
        $tgt_cmd = "$conf->{'bindir'}/receive_package \"$pname\" \"$pver\"";
2175 
        $ssh_cmd = sshCmd($tgt_cmd);
7387 dpurdie 2176 
        $ssh_cmd .= " <$tzfile"
6475 dpurdie 2177 
    }
2178 
 
1038 dpurdie 2179 
    $logger->verbose2("transferPackage:tgt_cmd:$tgt_cmd");
2180 
    $logger->verbose2("transferPackage:ssh_cmd:$ssh_cmd");
2181 
 
6776 dpurdie 2182 
    unless ($conf->{'noTransfers'}) {
2183 
        my $ph;
7387 dpurdie 2184 
        open ($ph, "$ssh_cmd |");
6776 dpurdie 2185 
        while ( <$ph> )
2186 
        {
2187 
            chomp;
2188 
            $logger->verbose2("transferPackage:Data: $_");
2189 
        }
2190 
        close ($ph);
2191 
        $cmdRv = $?;
2192 
        $logger->verbose("transferPackage:End: $?");
1038 dpurdie 2193 
    }
6148 dpurdie 2194 
 
7387 dpurdie 2195 
    return $cmdRv;
2196 
}
2197 
 
2198 
#-------------------------------------------------------------------------------
2199 
# Function        : transferPackageS3
2200 
#
2201 
# Description     : Transfer a package to an AWS S3 bucket
2202 
#                   Requires that the package already be tarZip-ed
2203 
#
2204 
# Inputs          : $tzdir  - Directory that contains the tarZip file
2205 
#                   $tzfile - Name of tarZip File
2206 
#                   $pname  - Package Name
2207 
#                   $pver   - Package Version
2208 
#
2209 
# Returns         : Result Code
2210 
#                   0   - Transfer OK
2211 
#                   <0  - Skip transfer
2212 
#                   >0  - Command error code
2213 
#
2214 
sub transferPackageS3
2215 
{
2216 
    my ($tzdir, $tzfile, $pname, $pver) = @_;
2217 
    my $cmdRv = 0;
2218 
 
6148 dpurdie 2219 
    #
7387 dpurdie 2220 
    #   Locate the file on the dpkgArchive tarZip store
2221 
    #
2222 
    my $sfile = catfile($tzdir, $tzfile);
2223 
    if (-l $sfile) {
2224 
        $logger->warn("Will not transfer symlink: $pname, $pver");
2225 
        return -1;
2226 
    }
2227 
 
6148 dpurdie 2228 
    #
7387 dpurdie 2229 
    #   Create a command to transfer the file to AWS use the cli tools
2230 
    #   Note: Ive seen problem with this when used from Perth to AWS (Sydney)
2231 
    #         If this is an issue use curl - see the savePkgToS3.sh for an implementation
2232 
    #
7460 dpurdie 2233 
    my $s3_cmd = "aws --profile $conf->{'S3Profile'}";
2234 
    $s3_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
2235 
    $s3_cmd .= " s3 cp $sfile s3://$conf->{'S3Bucket'}/$tzfile";
7387 dpurdie 2236 
    $logger->verbose2("transferPackage:s3_cmd:$s3_cmd");
2237 
 
2238 
    unless ($conf->{'noTransfers'}) {
6776 dpurdie 2239 
        my $ph;
7387 dpurdie 2240 
        open ($ph, "$s3_cmd |");
2241 
        while ( <$ph> )
2242 
        {
2243 
            chomp;
2244 
            $logger->verbose2("transferPackage:Data: $_");
2245 
        }
2246 
        close ($ph);
2247 
        $cmdRv = $?;
2248 
        $logger->verbose("transferPackage:End: $?");
6475 dpurdie 2249 
    }
6148 dpurdie 2250 
 
7387 dpurdie 2251 
    return $cmdRv;
1038 dpurdie 2252 
}
2253 
 
7387 dpurdie 2254 
 
1038 dpurdie 2255 
#-------------------------------------------------------------------------------
2256 
# Function        : deletePackage
2257 
#
2258 
# Description     : Delete specified package to target system
2259 
#
2260 
# Inputs          : $pname          - Name of the package
2261 
#                   $pver           - Package version
7394 dpurdie 2262 
#                   $mode           - 1 ForcedDelete 0: Tag for delayed Delete
1038 dpurdie 2263 
#
7389 dpurdie 2264 
# Returns         : true    - Package deleted
2265 
#                   false   - Package not deleted
1038 dpurdie 2266 
#
2267 
sub deletePackage
2268 
{
7394 dpurdie 2269 
    my ($pname, $pver, $mode ) = @_;
1038 dpurdie 2270 
    my $rv = 0;
6776 dpurdie 2271 
    my $cmdRv = 0;
1042 dpurdie 2272 
    $logger->logmsg("deletePackage: $pname, $pver");
1038 dpurdie 2273 
 
7389 dpurdie 2274 
    if ($isS3Target) {
7460 dpurdie 2275 
        #
2276 
        #   S3 Transfer is being used to store packages forever
2277 
        #   Don't normally want to be able to delete such packages, so the default
2278 
        #   is to prevent deletion of S3 transferred packages.
2279 
        if ($conf->{'S3AllowDelete'}) {
1038 dpurdie 2280 
 
7460 dpurdie 2281 
            #   Create the process pipe to delete the package
2282 
            my $tzfile = $pname . '__' . $pver . '.tgz';
2283 
            my $s3_cmd = "aws --profile $conf->{'S3Profile'}";
2284 
            $s3_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
2285 
            $s3_cmd .=   " s3 rm s3://$conf->{'S3Bucket'}/$tzfile";
2286 
            $logger->verbose2("deletePackage:s3_cmd:$s3_cmd");
1038 dpurdie 2287 
 
7460 dpurdie 2288 
            my $ph;
2289 
            open ($ph, "$s3_cmd |");
2290 
            while ( <$ph> )
2291 
            {
2292 
                chomp;
2293 
                $logger->verbose2("deletePackage:Data: $_");
2294 
            }
2295 
            close ($ph);
2296 
            $cmdRv = $?;
2297 
 
2298 
        } else {
2299 
            $logger->warn("deletePackage: S3Deletion disabled: $pname, $pver");
6776 dpurdie 2300 
        }
2301 
 
7389 dpurdie 2302 
    } else {
2303 
        #
2304 
        #   Create the process pipe to delete the package
2305 
        #   ssh  ... "./delete_package ${rx_opts} \"$pname\" \"$pver\""
2306 
        #
2307 
        unless ($conf->{'noTransfers'}) {
2308 
            my $ph;
7394 dpurdie 2309 
            my $flags = $mode  ? '-T' : '';
7389 dpurdie 2310 
            my $tgt_cmd = "$conf->{'bindir'}/delete_package $flags \"$pname\" \"$pver\"";
2311 
            my $ssh_cmd = sshCmd($tgt_cmd);
2312 
 
2313 
            $logger->verbose2("deletePackage:tgt_cmd:$tgt_cmd");
2314 
            $logger->verbose2("deletePackage:ssh_cmd:$ssh_cmd");
2315 
 
2316 
            open ($ph, "$ssh_cmd |");
2317 
            while ( <$ph> )
2318 
            {
2319 
                chomp;
2320 
                $logger->verbose2("deletePackage:Data: $_");
2321 
            }
2322 
            close ($ph);
2323 
            $cmdRv = $?;
2324 
        }
1038 dpurdie 2325 
    }
6776 dpurdie 2326 
 
7389 dpurdie 2327 
    #
2328 
    #   Common code
2329 
    #
2330 
    $logger->verbose("deletePackage:End: $cmdRv");
6776 dpurdie 2331 
    if ( $cmdRv == 0 )
1038 dpurdie 2332 
    {
2333 
        $rv = 1;
5398 dpurdie 2334 
        $statistics{delCount}++;
6148 dpurdie 2335 
        delete $RemotePkgList->{$pname}{$pver};
1038 dpurdie 2336 
    }
2337 
    else
2338 
    {
2339 
        $logger->warn("deletePackage:Error: $pname, $pver, $?");
2340 
    }
3515 dpurdie 2341 
    LogTxError ($?);
1038 dpurdie 2342 
    return $rv;
2343 
}
2344 
 
3515 dpurdie 2345 
#-------------------------------------------------------------------------------
2346 
# Function        : sshCmd
2347 
#
2348 
# Description     : Generate a ssh based command
2349 
#
2350 
# Inputs          : Target command
2351 
#
2352 
# Returns         : An shh command string
2353 
#
2354 
sub sshCmd
2355 
{
2356 
    my ($tgt_cmd) = @_;
3847 dpurdie 2357 
    my $sshPort = '';
2358 
    $sshPort = "-p $conf->{'sshport'}"
2359 
        if ($conf->{'sshport'});
2360 
 
2361 
    return "ssh -o \"BatchMode yes\" -i $conf->{'identity'} ${sshPort} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";
3515 dpurdie 2362 
}
1038 dpurdie 2363 
 
3515 dpurdie 2364 
 
1038 dpurdie 2365 
#-------------------------------------------------------------------------------
1042 dpurdie 2366 
# Function        : parsePkgList
2367 
#
2368 
# Description     : Parse one line from a pkgList
2369 
#                   Lines are multiple item="data" items
6148 dpurdie 2370 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
6475 dpurdie 2371 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" link="latest"
1042 dpurdie 2372 
#
2373 
# Inputs          : $line                   - Line of data
2374 
#                   $hashp                  - Ref to hash to populate
2375 
#
2376 
# Returns         : A hash of data items
2377 
#
2378 
sub parsePkgList
2379 
{
2380 
    my ($line, $hashp) = @_;
2381 
    my $rv;
2382 
 
2383 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2384 
    {
2385 
        $rv->{$1} = $2;
2386 
        $line = $';
2387 
    }
2388 
#Utils::DebugDumpData ("parsePkgList", $rv);
2389 
 
2390 
    my $pname = $rv->{pname};
2391 
    my $pver =  $rv->{pver};
2392 
    return undef unless ( $pname && $pver );
2393 
 
2394 
    delete $rv->{pname};
2395 
    delete $rv->{pver};
2396 
    delete $rv->{GMT};
2397 
 
2398 
    $hashp->{$pname}{$pver} = $rv;
2399 
    return $hashp;
2400 
}
2401 
 
5398 dpurdie 2402 
#-------------------------------------------------------------------------------
5404 dpurdie 2403 
# Function        : parsePkgMetaData
2404 
#
2405 
# Description     : Parse one line of meta data from a pkgList
2406 
#                   Lines are multiple item="data" items
2407 
#
2408 
# Inputs          : $line                   - Line of data
2409 
#                   $hashp                  - Ref to hash to populate
2410 
#
2411 
# Returns         : Nothing
2412 
#
2413 
sub parsePkgMetaData
2414 
{
2415 
    my ($line, $hashp) = @_;
2416 
 
2417 
    if ( $line =~ m~\s+(.+?)="(.+?)"~ )
2418 
    {
2419 
        $hashp->{$1} = $2;
2420 
        $statistics{'Target.' . $1} = $2;
2421 
        $line = $';
2422 
 
2423 
        $logger->verbose2("parsePkgMetaData: $1 = $2");
2424 
    }
2425 
}
2426 
 
6320 dpurdie 2427 
#-------------------------------------------------------------------------------
2428 
# Function        : parseBlatBinData
2429 
#
2430 
# Description     : Parse one line of Blat Bin data from a pkgList
2431 
#                   Lines are of the form:
2432 
#                   BlatBin MD5="dbc4507f4db5b41f7358b28bce65a15d" file="ddp-gtar"
2433 
#
2434 
# Inputs          : $line                   - Line of data
2435 
#                   $hashp                  - Ref to hash to populate
2436 
#
2437 
# Returns         : Nothing
2438 
#
2439 
sub parseBlatBinData
2440 
{
2441 
    my ($line, $hashp) = @_;
5404 dpurdie 2442 
 
6320 dpurdie 2443 
    my $rv;
2444 
    $line =~ s~^\S+~~;
2445 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2446 
    {
2447 
        $rv->{$1} = $2;
2448 
        $line = $';
2449 
    }
2450 
#Utils::DebugDumpData ("parseBlatBinData", $rv);
2451 
 
2452 
    my $fname = $rv->{file};
2453 
    my $md5 =  $rv->{MD5};
2454 
    return undef unless ( $fname && $md5 );
2455 
 
2456 
    $logger->verbose2("parseBlatBinData: $fname : $md5");
2457 
    $hashp->{$fname} = $md5;
2458 
}
2459 
 
5404 dpurdie 2460 
#-------------------------------------------------------------------------------
5398 dpurdie 2461 
# Function        : resetDailyStatistics
2462 
#
2463 
# Description     : Called periodically to reset the daily statistics
2464 
#
2465 
# Inputs          : $time       - Current time
2466 
#
2467 
# Returns         :
2468 
#
2469 
sub resetDailyStatistics
2470 
{
2471 
    my ($time) = @_;
1042 dpurdie 2472 
 
5398 dpurdie 2473 
    #
2474 
    #   Detect a new day
2475 
    #
2476 
    my $today = (localtime($time))[7];
2477 
    if ($yday != $today)
2478 
    {
2479 
        $yday = $today;
2480 
        $logger->logmsg('Resetting daily statistics' );
2481 
 
5404 dpurdie 2482 
        # Note: Must match @recoverTags in readStatistics
5398 dpurdie 2483 
        $statistics{dayStart} = $time;
2484 
        $statistics{txCount} = 0;
2485 
        $statistics{delCount} = 0;
2486 
        $statistics{staleTags} = 0;
2487 
        $statistics{linkErrors} = 0;
2488 
    }
2489 
}
2490 
 
1042 dpurdie 2491 
#-------------------------------------------------------------------------------
5404 dpurdie 2492 
# Function        : readStatistics
2493 
#
2494 
# Description     : Read in the last set of stats
2495 
#                   Used after a restart to recover daily statistics
2496 
#
2497 
# Inputs          :
2498 
#
2499 
# Returns         :
2500 
#
2501 
sub readStatistics
2502 
{
2503 
    my @recoverTags = qw(dayStart txCount delCount staleTags linkErrors);
2504 
 
2505 
    if ($conf->{'statsfile'} and -f $conf->{'statsfile'})
2506 
    {
2507 
        if (open my $fh, $conf->{'statsfile'})
2508 
        {
2509 
            while (<$fh>)
2510 
            {
2511 
                m~(.*):(.*)~;
2512 
                if ( grep( /^$1$/, @recoverTags ) )
2513 
                {
2514 
                    $statistics{$1} = $2;
6475 dpurdie 2515 
                    $logger->verbose("readStatistics $1, $2");
5404 dpurdie 2516 
                }
2517 
            }
2518 
            close $fh;
2519 
            $yday = (localtime($statistics{dayStart}))[7];
2520 
        }
2521 
    }
2522 
}
2523 
 
2524 
 
2525 
#-------------------------------------------------------------------------------
5398 dpurdie 2526 
# Function        : periodicStatistics
2527 
#
2528 
# Description     : Called on a regular basis to write out statistics
2529 
#                   Used to feed information into Nagios
2530 
#
2531 
#                   This function is called via an alarm and may be outside the normal
2532 
#                   processing loop. Don't make assumptions on the value of $now
2533 
#
2534 
# Inputs          :
2535 
#
2536 
# Returns         :
2537 
#
2538 
sub periodicStatistics
2539 
{
2540 
    #
2541 
    #   A few local stats
2542 
    #
2543 
    $statistics{SeqNum}++;
2544 
    $statistics{timeStamp} = time();
2545 
    $statistics{upTime} = $statistics{timeStamp} - $startTime;
7460 dpurdie 2546 
    $statistics{wedged} = Utils::isWedged($conf);
7397 dpurdie 2547 
    $statistics{state} = $statistics{wedged} ? 'Wedged' : $statistics{state};
2548 
 
5398 dpurdie 2549 
 
2550 
    #   Reset daily accumulations - on first use each day
2551 
    resetDailyStatistics($statistics{timeStamp});
2552 
 
2553 
    #
2554 
    #   Write statistics to a file
2555 
    #       Write to a tmp file, then rename.
2556 
    #       Attempt to make the operation atomic - so that the file consumer
2557 
    #       doesn't get a badly formed file.
2558 
    #
2559 
    if ($conf->{'statsfiletmp'})
2560 
    {
2561 
        my $fh;
2562 
        unless (open ($fh, '>', $conf->{'statsfiletmp'}))
2563 
        {
2564 
            $fh = undef;
2565 
            $logger->warn("Cannot create temp stats file: $!");
2566 
        }
2567 
        else
2568 
        {
5404 dpurdie 2569 
            foreach my $key ( sort { lc($a) cmp lc($b) } keys %statistics)
5398 dpurdie 2570 
            {
2571 
                print $fh $key . ':' . $statistics{$key} . "\n";
2572 
                $logger->verbose2('Statistics:'. $key . ':' . $statistics{$key});
2573 
            }
2574 
            close $fh;
2575 
 
2576 
            # Rename temp to real file
2577 
            rename  $conf->{'statsfiletmp'},  $conf->{'statsfile'} ;
2578 
        }
2579 
    }
2580 
}
2581 
 
2582 
#-------------------------------------------------------------------------------
1038 dpurdie 2583 
# Function        : sighandlers
2584 
#
2585 
# Description     : Install signal handlers
2586 
#
2587 
# Inputs          : $conf           - System config
2588 
#
2589 
# Returns         : Nothing
2590 
#
2591 
sub sighandlers
2592 
{
5398 dpurdie 2593 
    $SIG{TERM} = sub {
2594 
        # On shutdown
2595 
        $logger->logmsg('Received SIGTERM. Shutting down....' );
2596 
        unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
2597 
        exit 0;
2598 
    };
1038 dpurdie 2599 
 
5398 dpurdie 2600 
    $SIG{HUP} = sub {
2601 
        # On logrotate
2602 
        $logger->logmsg('Received SIGHUP.');
2603 
        $logger->rotatelog();
2604 
    };
1038 dpurdie 2605 
 
5398 dpurdie 2606 
    $SIG{USR1} = sub {
2607 
        # On Force Archive Sync
2608 
        $logger->logmsg('Received SIGUSR1.');
1046 dpurdie 2609 
        $lastReleaseScan = 0;
6779 dpurdie 2610 
        $lastTagListUpdate = 0;
6776 dpurdie 2611 
        $lastRmConfRead = 0;
5398 dpurdie 2612 
    };
1038 dpurdie 2613 
 
7387 dpurdie 2614 
    alarm 60 unless $conf->{debug};
5398 dpurdie 2615 
    $SIG{ALRM} = sub {
2616 
        # On Dump Statistics
2617 
        $logger->verbose2('Received SIGUSR2.');
2618 
        periodicStatistics();
2619 
        alarm 60;
2620 
    };
2621 
 
1038 dpurdie 2622 
    $SIG{__WARN__} = sub { $logger->warn("@_") };
2623 
    $SIG{__DIE__} = sub { $logger->err("@_") };
2624 
}
2625 
 
2626 
#-------------------------------------------------------------------------------
3515 dpurdie 2627 
# Function        : LogTxError
2628 
#
2629 
# Description     : Detect restoration of communication and log such
2630 
#                   Don't log failures as the user will do that
2631 
#
2632 
# Inputs          : $state                  - 0 - All is well
2633 
#                                           !0  - Error
2634 
#
2635 
# Returns         : Nothing
2636 
#
2637 
sub LogTxError
2638 
{
2639 
    my ($state) = $@;
2640 
    if ( $state )
2641 
    {
5398 dpurdie 2642 
        $statistics{linkErrors}++ unless($comError);
3515 dpurdie 2643 
        $comError++;
5398 dpurdie 2644 
        $statistics{state} = 'No Communication';
3515 dpurdie 2645 
    }
2646 
    elsif ( $comError )
2647 
    {
2648 
        $logger->warn("Communication Restored");
2649 
        $comError = 0;
5398 dpurdie 2650 
        $statistics{state} = 'OK';
3515 dpurdie 2651 
    }
2652 
}
2653 
 
2654 
 
2655 
#-------------------------------------------------------------------------------
1038 dpurdie 2656 
# Function        : Error, Verbose, Warning
2657 
#
2658 
# Description     : Support for JatsRmApi
2659 
#
2660 
# Inputs          : Message
2661 
#
2662 
# Returns         : Nothing
2663 
#
2664 
sub Error
2665 
{
2666 
    $logger->err("@_");
2667 
}
2668 
 
2669 
sub Verbose
2670 
{
1042 dpurdie 2671 
    $logger->verbose2("@_");
1038 dpurdie 2672 
}
2673 
 
2674 
sub Warning
2675 
{
2676 
    $logger->warn("@_");
2677 
}
2678