Subversion Repositories DevTools

Rev

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