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

 my $targetBinDir = "$FindBin::Bin/targetBin";
 my $server_id;
 my @projectList;
 my @releaseList;
 my $isS3Target;
-my $wedgedCount = 0;
+#
 #   Contain statisics maintained while operating
 #       Can be dumped with a kill -USR2
 #       List here for documentation
     'active'          => {'default'   => 1      , 'fmt' => 'bool'},
     'debug'           => {'default'   => 0      , 'fmt' => 'bool'},                 # Log to screen
     'txdetail'        => {'default'   => 0      , 'fmt' => 'bool'},
     'noTransfers'     => {'default'   => 0      , 'fmt' => 'bool'},                 # Debugging option to prevent transfers
     'maxTarZips'      => {'default'   => 5      , 'fmt' => 'int'},
+    'wedgeTime'       => {'default'   => '30m'  , 'fmt' => 'period'},
+    #
     #   Transfer via ssh
     #   Cannot be used in conjunction with S3Bucket
+    #
-    'hostname'        => {'fmt' => 'text', requires => 'user,identity,bindir'},
+    'hostname'        => {'fmt' => 'text', 'requires' => 'user,identity,bindir'},
-    'user'            => {'fmt' => 'text', requires => 'hostname'},
+    'user'            => {'fmt' => 'text', 'requires' => 'hostname'},
     'identity'        => {'fmt' => 'file'},
     'bindir'          => {'fmt' => 'text'},
+    #
     #   Transfer to S3 configuration items
     #       Cannot be used in conjunction with hostname
     #       Many other options will be ignored
+    #
-    'S3Bucket'        => {'fmt' => 'text', requires => 'S3Profile'},
+    'S3Bucket'        => {'fmt' => 'text', 'requires' => 'S3Profile,S3Profile,S3Region'},
-    'S3Profile'       => {'fmt' => 'text', requires => 'S3Bucket' },
+    'S3Profile'       => {'fmt' => 'text', 'requires' => 'S3Bucket' },
+    'S3Region'        => {'fmt' => 'text', 'requires' => 'S3Bucket' },
+    'S3AllowDelete'   => {'default' => 0 , 'fmt' => 'bool'},
 );
+#
 #   Read in the configuration
+#
 while (1)
+{
     $logger->verbose3("Processing");
     $statistics{Cycle}++;
-    $wedgedCount = 0;
     $now = time();
+    Utils::resetWedge();
     $statistics{phase} = 'ReadConfig';
     readConfig();
     if ( $conf->{'active'} )
+    {
+        {
             warn "$_\n" foreach (@{$errors});
             die ("Config contained errors\n");
+        }
         $isS3Target = defined $conf->{'S3Bucket'};
+        if ($isS3Target) {
+            if (!$conf->{'S3AllowDelete'}) {
+                    $conf->{deletePackages} = 0;
+            }
+        }
+        #
         #   Reset some information
         #   Create a new logger
+        #
     #   Get Data from an S3 bucket
     #   Can only get a part of the full data set. The timestamp can't be processed, so set it to -1
+    #
     if ($isS3Target ) {
         my $ph;
+        my $tgt_cmd = "aws --profile $conf->{'S3Profile'}";
+        $tgt_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
-        my $tgt_cmd = "aws s3 ls $conf->{'S3Bucket'}/";
+        $tgt_cmd .= " s3 ls $conf->{'S3Bucket'}/";
         $logger->verbose2("processReleaseList:s3_cmd:$tgt_cmd");
         open ($ph, "$tgt_cmd |");
         while ( <$ph> )
+        {
             chomp;
-            m~.*\s(.*)__(.*).tgz$~;
+            if (m~.*\s(.*)__(.*).tgz$~ ) {
-            $remotePkgList->{$1}{$2}{s3} = 1;
+                $remotePkgList->{$1}{$2}{s3} = 1;
+            }
+        }
         close ($ph);
     } else {
         # Get Data from a dpkg_archive maintained via ssh
+        }
+        #
         #   Process each entry
         #   Ignore those that start with a .
+        #   Attempt to keep the entries in time of creation order.
+        #
-        my %tagPkgList;
+        my @tagPkgList;
         my %deleteTags;
+        my @sortedFiles = sort {(stat($conf->{'tagdir'} .'/'. $a))[10] <=> (stat($conf->{'tagdir'} .'/'. $b))[10]} readdir($dh);
+        closedir $dh;
-        while (my $tag = readdir($dh) )
+        foreach my $tag (@sortedFiles)
+        {
             next if ( $tag =~ m~^\.~ );
             my $file = "$conf->{'tagdir'}/$tag";
             $logger->verbose3("processTags: $file");
                 $delCount++;
+            }
             if ( $tag =~ m~(.+)::(.+)~  )
+            {
-                $tagPkgList{$1}{$2} = $file;
+                push @tagPkgList, join($;,  $1, $2, $file);
                 $tagCount++;
+            }
+        }
         $statistics{tagCount} = $tagCount;
         $statistics{tagDelCount} = $delCount;
-        closedir $dh;
+        #
         #   Process delete requests after all transfers have occured
+        #
         unless ($tagCount) {
                     deletePackage ($pname, $pver, $pdata->{mode});
                     unlink $pdata->{file};
                     $delCount--;
                     reapChildren();
-                    $wedgedCount = 0;
+                    Utils::resetWedge();
+                }
+            }
+        }
+        #
         #   Process the packages located in the tags area
+        #   Have attempted to keep them in creation order
+        #
         send_tags:
-        while ( (my ($package, $pvers)) = each %{tagPkgList} )
+        foreach my $entry ( @tagPkgList )
+        {
-            while ( (my ($version, $file) ) = each %{$pvers} )
+            my ($package, $version, $file) = split ($;, $entry);
+            if ( --$txcount <= 0 )
+            {
-                if ( --$txcount <= 0 )
-                {
-                    $logger->warn("Max tag transfer count exceeded: $tagCount transfer remaining");
+                $logger->warn("Max tag transfer count exceeded: $tagCount transfer remaining");
-                    $logger->warn("Max tag transfer count exceeded: $delCount deletion remaining");
+                $logger->warn("Max tag transfer count exceeded: $delCount deletion remaining");
-                    $tagDirTime = 0;
+                $tagDirTime = 0;
-                    last send_tags;
+                last send_tags;
-                }
+            }
-                if ( readConfig() )
+            if ( readConfig() )
-                {
+            {
-                    $logger->warn("Config file changed");
+                $logger->warn("Config file changed");
-                    $txcount = 0;
+                $txcount = 0;
-                    $tagDirTime = 0;
+                $tagDirTime = 0;
-                    last send_tags;
+                last send_tags;
-                }
+            }
 #               #
 #               #   Don't transfer 'extra' packages
 #               #   Removed. It was casuing a tarZip to be triggered, but never transferred
 #               #
 #               {
 #                   $logger->warn ("Delete excess package tag: $package::$version");
 #                   unlink $file;
+#
 #               } else
-                if ( transferPackage( $package, $version )) {
+            if ( transferPackage( $package, $version )) {
-                    unlink $file;
+                unlink $file;
-                }
+            }
-                else
+            else
-                {
+            {
-                    if ($conf->{'tagage'} > 0) {
+                if ($conf->{'tagage'} > 0) {
-                        my ($mtime) = Utils::mtime( $file );
+                    my ($mtime) = Utils::mtime( $file );
-                        if ( $now - $mtime > $conf->{'tagage'} )
+                    if ( $now - $mtime > $conf->{'tagage'} )
-                        {
+                    {
-                            $logger->warn ("Delete unsatisfied tag: $package::$version after $conf->{'tagage'}" );
+                        $logger->warn ("Delete unsatisfied tag: $package::$version after $conf->{'tagage'}" );
-                            unlink $file;
+                        unlink $file;
-                            $statistics{staleTags}++;
+                        $statistics{staleTags}++;
-                        }
+                    }
+                }
-                $tagCount--;
-                reapChildren();
-                $wedgedCount = 0;
+            }
+            $tagCount--;
+            reapChildren();
+            Utils::resetWedge();
+        }
+    }
+}
 #-------------------------------------------------------------------------------
 # Inputs          : $pname          - Name of the package
 #                   $pver           - Package version
+#
 # Returns         : true    - Package transferred
 #                   false   - Package not transferred
+#
+#
+#                   PackageExcluded         - Assume that its been transferred
+#                   PackageAtTarget         - Package known to be on the target
+#                   PackageNotInArchive     - Package not found in dpkg_archive
+#                   PackageZipRequested     - Requested a Zipped version of the package
+#                   PackageZipNotRequested  - Need a Zipped version, but I have too many requests outstanding
+#                   PackageTransferOK       - Package has been transferred
+#                   PackageTransferError    - Error in the package transfer
+#
+#
+#
 sub transferPackage
+{
     my ($pname, $pver ) = @_;
     my $rv = 0;
         my $tagRoot = $1;
         my $tag = "$pname::$pver";
         my $zipTag = catfile($tagRoot, 'tarZip', $tag);
         my $myTag =  catfile($conf->{'tagdir'} , $tag);
-        $logger->logmsg("transferPackage. Request Zip: @_") unless ( -f $zipTag && -f $myTag );
+        # Ensure I have an outstanding request, so that the tarZip process can notify me
         Utils::TouchFile($conf, $myTag) unless -f $myTag;
         unless (-f $zipTag) {
             if (calcZipRequests() < $conf->{maxTarZips} ) {
+                $logger->logmsg("transferPackage. Request Zip: @_");
                 Utils::TouchFile($conf, $zipTag);
             } else {
                 $logger->verbose("transferPackage: Max outstanding tarZip Requests");
+            }
+        }
+    #
     #   Create a command to transfer the file to AWS use the cli tools
     #   Note: Ive seen problem with this when used from Perth to AWS (Sydney)
     #         If this is an issue use curl - see the savePkgToS3.sh for an implementation
+    #
+    my $s3_cmd = "aws --profile $conf->{'S3Profile'}";
+    $s3_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
-    my $s3_cmd = "aws --profile $conf->{'S3Profile'} s3 cp $sfile s3://$conf->{'S3Bucket'}/$tzfile";
+    $s3_cmd .= " s3 cp $sfile s3://$conf->{'S3Bucket'}/$tzfile";
     $logger->verbose2("transferPackage:s3_cmd:$s3_cmd");
     unless ($conf->{'noTransfers'}) {
         my $ph;
         open ($ph, "$s3_cmd |");
     my $rv = 0;
     my $cmdRv = 0;
     $logger->logmsg("deletePackage: $pname, $pver");
     if ($isS3Target) {
+        #
+        #   S3 Transfer is being used to store packages forever
+        #   Don't normally want to be able to delete such packages, so the default
+        #   is to prevent deletion of S3 transferred packages.
+        if ($conf->{'S3AllowDelete'}) {
-        #   Create the process pipe to delete the package
+            #   Create the process pipe to delete the package
+            my $tzfile = $pname . '__' . $pver . '.tgz';
+            my $s3_cmd = "aws --profile $conf->{'S3Profile'}";
+            $s3_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
+            $s3_cmd .=   " s3 rm s3://$conf->{'S3Bucket'}/$tzfile";
+            $logger->verbose2("deletePackage:s3_cmd:$s3_cmd");
+            my $ph;
-        my $tzfile = $pname . '__' . $pver . '.tgz';
+            open ($ph, "$s3_cmd |");
-        my $s3_cmd = "aws --profile $conf->{'S3Profile'} s3 rm s3://$conf->{'S3Bucket'}/$tzfile";
+            while ( <$ph> )
+            {
+                chomp;
-        $logger->verbose2("deletePackage:s3_cmd:$s3_cmd");
+                $logger->verbose2("deletePackage:Data: $_");
+            }
+            close ($ph);
+            $cmdRv = $?;
-        my $ph;
+        } else {
-        open ($ph, "$s3_cmd |");
-        while ( <$ph> )
-        {
-            chomp;
-            $logger->verbose2("deletePackage:Data: $_");
+            $logger->warn("deletePackage: S3Deletion disabled: $pname, $pver");
+        }
-        close ($ph);
-        $cmdRv = $?;
     } else {
+        #
         #   Create the process pipe to delete the package
         #   ssh  ... "./delete_package ${rx_opts} \"$pname\" \"$pver\""
     #   A few local stats
+    #
     $statistics{SeqNum}++;
     $statistics{timeStamp} = time();
     $statistics{upTime} = $statistics{timeStamp} - $startTime;
-    $statistics{wedged} = $wedgedCount++ > 30  ? 1 : 0;
+    $statistics{wedged} = Utils::isWedged($conf);
     $statistics{state} = $statistics{wedged} ? 'Wedged' : $statistics{state};
     #   Reset daily accumulations - on first use each day
     resetDailyStatistics($statistics{timeStamp});

Subversion Repositories DevTools

(root)/dpkg_blat/trunk/src/blat/blatDaemon.pl – Rev 7423 → 7460