deploy_content

Modules

Functions:


Main Script

Variables:

Calls:

Comments:

#!/opt/ims/perl5/bin/perl
##############################################################################
#
#                                Confidential
#             Disclosure And Distribution Solely to Employees of
#          Hewlett-Packard and Its Affiliates Having a Need to Know
#
#                  Copyright @ 1998, Hewlett-Packard, Inc.,
#                            All Rights Reserved
#
##############################################################################
#
#   @(#)$Id: deploy_content_doc.html,v 1.1 2000/05/04 21:14:28 idsweb Exp $
#
#   Description:    Take the info file passed in and manage the verification
#                   of the fields, the population of data into the staging
#                   and release areas, and effect the posting of the data to
#                   other servers in the mirror pool if requested.
#
#   Functions:      read_info
#                   send_mail
#                   mirror_propagate
#
#   Libraries:      IMS::ReleaseMgr::Signature
#                   Carp                    Core lib (better error messages)
#                   File::Copy              Core lib (smart 'mv' clone)
#                   File::Path              Core lib (emulate 'rm -rf' in Perl)
#                   Fcntl                   Core lib (flock constants)
#                   IO::File                Core lib (I/O classes)
#                   Getopt::Long            Core lib (cmd-line parsing)
#                   Sys::Hostname           Core lib (smart 'hostname' command)
#                   Net::Domain             CPAN lib for getting FQDN
#                   Mail::Internet          CPAN lib for sending UNIX mail
#                   Mail::Header              part of the above
#                   LWP::UserAgent          \
#                   HTTP::Request::Common    > CPAN libs, used for mirroring
#                   URI::URL                /
#
#   Global Consts:  $cmd                    This tool's name
#                   $USAGE                  The tool usage error message
#
#   Environment:    PATH                    This has to be trimmed drastically
#                                             for security
#
##############################################################################
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};;
#
# The Archive::Tar package handles compression automatically. However, that
# means that the file could possibly arrive with a ".gz" suffix to the name.
# Later, when deriving the tarfile name, we only want to accept that suffix
# as a contender if this mirror is configured to use compression.
#
    #
    # Set up a file for tracing to write to. In absence of -T, we use STDOUT
    #
if ($trace & 8) # bxxxx1xxx
# Make sure that the argument the program was called with is
# actually a name of a file present in the either $stage_dir or $incoming_dir.
# If not, exit with an error message.
# Parse the lines into hash keys, leave only the old-style digital signature
# (if present) in @info:
# Take the argument, delete the part of the path which denotes the directory
# and the suffix ".info".
# If the tarred file is not there, exit with an error message
# time calculation - roughly equivalent to date +%y%m%d
#
# pick up the info file and move it
#     Moving it prevents the monitor from trying to run another process to
#     handle this data.
#
    # Hmm... the topic dir is already here...
        # 36 iterations with a 5-sec sleep-- give them 3 minutes to finish
#
# Check again and move things back around if the dir is still there
#
#
# Give a heads-up on whether the content arrived in compressed form
#
#
# Check the MD5 stamp if one is present. This is not yet required, but probably
# will be once the overall system is finished on both ends.
#
        #
        # Signatures don't match. We cannot release this content.
        #
# Untar the topic to be pushed
#
# We don't have to actually worry about the "compressed" header, since the
# Archive::Tar class auto-detects compressed content.
#
#
# At this point, safe to assume that it worked.
#
# Use process_content (or user-specified tool) to push out new data
#
# $file is the destination, minus leading /. Tar should have left a directory
# by that name in $stage_dir.
#
#
# Construct the command to execute, based on the value of $script and the
# command-line args that need to be carried over.
#
# Have had some problems with IO::Pipe in the past
# This routine from File::Path does a clean, recursive deletion
#
# Mirror the data if we are using an RDBMS model. If there are no mirrors,
# this routine won't do anything.
#
    #
    # Remove the staging directory, as we don't want to interfere with future
    # release attempts (mirrors be darned...)
    #
# remove the tar file (info file already moved)
##############################################################################
#
#   Sub Name:       read_info
#
#   Description:    Read the info file, converting the Info:xxxx lines into
#                   hash keys and trimming the input list down to all "extra"
#                   lines (which will later be treated as the checksum/
#                   signature of the tar file).
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $href     in      hashref   The hash to store key/value
#                                                 pairs in
#                   $lref     in      listref   The lines from the info file.
#                                                 On exit will be pared down to
#                                                 just the checksum lines.
#
#   Globals:        $trace
#                   $tfile
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    dies
#
##############################################################################/n

Code:

#!/opt/ims/perl5/bin/perl
    eval 'exec perl -S $0 "$@"'
        if 0;

##############################################################################
#
#                                Confidential
#             Disclosure And Distribution Solely to Employees of
#          Hewlett-Packard and Its Affiliates Having a Need to Know
#
#                  Copyright @ 1998, Hewlett-Packard, Inc.,
#                            All Rights Reserved
#
##############################################################################
#
#   @(#)$Id: deploy_content_doc.html,v 1.1 2000/05/04 21:14:28 idsweb Exp $
#
#   Description:    Take the info file passed in and manage the verification
#                   of the fields, the population of data into the staging
#                   and release areas, and effect the posting of the data to
#                   other servers in the mirror pool if requested.
#
#   Functions:      read_info
#                   send_mail
#                   mirror_propagate
#
#   Libraries:      IMS::ReleaseMgr::Signature
#                   Carp                    Core lib (better error messages)
#                   File::Copy              Core lib (smart 'mv' clone)
#                   File::Path              Core lib (emulate 'rm -rf' in Perl)
#                   Fcntl                   Core lib (flock constants)
#                   IO::File                Core lib (I/O classes)
#                   Getopt::Long            Core lib (cmd-line parsing)
#                   Sys::Hostname           Core lib (smart 'hostname' command)
#                   Net::Domain             CPAN lib for getting FQDN
#                   Mail::Internet          CPAN lib for sending UNIX mail
#                   Mail::Header              part of the above
#                   LWP::UserAgent          \
#                   HTTP::Request::Common    > CPAN libs, used for mirroring
#                   URI::URL                /
#
#   Global Consts:  $cmd                    This tool's name
#                   $USAGE                  The tool usage error message
#
#   Environment:    PATH                    This has to be trimmed drastically
#                                             for security
#
##############################################################################
use vars qw($cmd);
($cmd = $0) =~ s|.*/||o;

use 5.004;

use strict;
use vars qw($USAGE $server_root $incoming_dir $stage_dir $htdocs_dir $log_dir
            $push_log_dir $timestamp $hostname $file $webmaster $push_log_file
            $trace $tfile $script %info @info $FH @res_text $basefile $tarfile
            $workfile @command $email_list $error_email_list $basedir %opts
            $config $mirror_group $MIRROR_RETRIES $MIRROR_WAIT_PERIOD $tar
            $VERSION $revision $compression_support);
use subs qw(read_info send_mail mirror_propagate Archive::Tar::error);

use Carp                   qw(carp croak);
use Cwd                    'cwd';
use File::Copy             'move';
use File::Path             qw(rmtree mkpath);
use Fcntl                  ':flock';
use Getopt::Long           'GetOptions';
use Sys::Hostname          'hostname';
use Net::Domain            'hostfqdn';
use LWP::UserAgent;
use HTTP::Request::Common  qw(POST $DYNAMIC_FILE_UPLOAD);
use URI::URL;
require IO::File;
require Mail::Header;
require Mail::Internet;
require Text::Wrap;
require Archive::Tar;

use IMS::ReleaseMgr::Utils     qw(write_log_line send_mail show_version
                                  file_mirror_specification
                                  file_mirror_host_list
                                  file_error
                                  DBI_mirror_specification
                                  DBI_mirror_host_list
                                  DBI_error);
use IMS::ReleaseMgr::Transfer  'mirror_upload';
use IMS::ReleaseMgr::Signature 'md5_signature';

($basedir = $0) =~ s|^(.*)/(.*)$|$1|o;
$basedir = cwd if ($basedir eq '.');
$ENV{PATH} = "$basedir:/bin:/usr/bin:/sbin:/opt/ims/bin";
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};;
$revision = q{$Id: deploy_content_doc.html,v 1.1 2000/05/04 21:14:28 idsweb Exp $ };

$USAGE = "Usage: $cmd mirror_group file [ -H host ] [ -t level ] [ -T file ]
\t[ -c file ]

Where:
-H host\t\tUse 'host' for identification (instead of system value)
-t num\t\tEnable tracing (num sets level)
-T file\t\tSend trace information to 'file' instead of tty
-c file\t\tRead configuration from 'file' instead of DBMS

``file'' is the release manager ticket file, and must end in ``.info''.
``mirror_group'' is the name of the host-pool grouping that this process is
running as a part of. It is used as a search key in the DBMS.
";
if (grep($_ eq '-h', @ARGV))
{
    print "$USAGE\n$revision\n";
    exit 0;
}
exit show_version if (grep(/-version/i, @ARGV));

$MIRROR_RETRIES     = 3;
$MIRROR_WAIT_PERIOD = 30;

$SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /bad free/oi; };
Getopt::Long::config 'no_ignore_case';
GetOptions(\%opts, 'H=s', 't=i', 'T=s', 'c=s') or croak "$USAGE\nStopped";
$mirror_group = shift || croak "$USAGE\nStopped";
$file         = shift || croak "$USAGE\nStopped";

if (defined $opts{c} and $opts{c})
{
    $config = file_mirror_specification(-file => $opts{c});
    croak "$cmd was unable to get data for $mirror_group from file $opts{c}," .
        " stopped" unless (defined $config);
}
else
{
    $config = DBI_mirror_specification(-mirror => $mirror_group);
    croak "$cmd was unable to get data for $mirror_group from Oracle, stopped"
        unless (defined $config);
}

$hostname = hostname;

$trace        = $opts{t}                   || 0;
$tfile        = $opts{T}                   || '-';
$server_root  = $config->{SERVER_ROOT}     || '/opt/ims';
$incoming_dir = $config->{INCOMING_DIR}    || "$server_root/incoming";
$stage_dir    = $config->{STAGING_DIR}     || "$server_root/staging";
$htdocs_dir   = $config->{DOCUMENT_ROOT}   || "$server_root/htdocs";
$log_dir      = $config->{LOGGING_DIR}     || "$server_root/logs";
$push_log_dir = $config->{PKG_LOGGING_DIR} || "$log_dir/Pushes";
$webmaster    = $config->{WEBMASTER}       || 'webmaster@nafohq.hp.com';
$script       = $config->{STAGE_3_TOOL}    || 'process_content';
#
# The Archive::Tar package handles compression automatically. However, that
# means that the file could possibly arrive with a ".gz" suffix to the name.
# Later, when deriving the tarfile name, we only want to accept that suffix
# as a contender if this mirror is configured to use compression.
#
$compression_support = (defined $config->{COMPRESSION} and
                        $config->{COMPRESSION} !~ /no|false|0/i);

if ($trace)
{
    #
    # Set up a file for tracing to write to. In absence of -T, we use STDOUT
    #
    write_log_line $tfile, sprintf("$cmd [$$] [%s] Started with tracing",
                                   (scalar localtime));
}

if ($trace & 8) # bxxxx1xxx
{
    write_log_line($tfile,
                   map {
                       sprintf("$cmd [$$] CONFIG: %18s => %s",
                               $_, $config->{$_})
                   } (sort keys %$config));
}

write_log_line("$log_dir/$cmd", sprintf("%s [$$] Called to deploy for $file",
                                        scalar localtime));

# Make sure that the argument the program was called with is
# actually a name of a file present in the either $stage_dir or $incoming_dir.
# If not, exit with an error message.
if (-f "$stage_dir/$file")
{
    $workfile = "$stage_dir/$file";
}
elsif (-f "$incoming_dir/$file")
{
    $workfile = "$incoming_dir/$file";
}
else
{
    croak "Error: Can't find $stage_dir/$file or $incoming_dir/$file, stopped";
}

$FH = new IO::File "< $workfile";
if (! defined $FH)
{
    croak "Error opening $file for reading: $!, stopped";
}
chomp(@info = <$FH>);
$FH->close;

# Parse the lines into hash keys, leave only the old-style digital signature
# (if present) in @info:
read_info \%info, \@info;
if ($trace & 1)
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Package destination is %s",
                           (scalar localtime), $info{dest}));
}
$email_list = (defined $info{email} and $info{email}) ? $info{email} : '';
$email_list =~ tr/, /,/s;
$email_list =~ s/^,//o;
$error_email_list = (length $email_list) ?
    "$error_email_list,$webmaster" : $webmaster;

# Take the argument, delete the part of the path which denotes the directory
# and the suffix ".info".
($basefile = $file) =~ s/\.info$//o;

# If the tarred file is not there, exit with an error message
if (-f "$incoming_dir/$basefile.tar")
{
    $tarfile = "$incoming_dir/$basefile.tar";
}
elsif ($compression_support and -f "$incoming_dir/$basefile.tar.gz")
{
    $tarfile = "$incoming_dir/$basefile.tar.gz";
}
elsif (-f "$server_root/$basefile.tar")
{
    $tarfile = "$server_root/$basefile.tar";
}
elsif ($compression_support and -f "$server_root/$basefile.tar.gz")
{
    $tarfile = "$server_root/$basefile.tar.gz";
}
else
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Found no tar archive %s.tar",
                           (scalar localtime), $basefile))
        if ($trace);
    write_log_line("$log_dir/$cmd",
                   sprintf("%s [$$] Fatal error: No $basefile.tar found",
                           scalar localtime));
    rename $workfile, "$workfile.NO_TAR";
    croak "Error: can't find $server_root/$basefile.tar or " .
        "$incoming_dir/$basefile.tar, stopped";
}

if ($trace & 4)
{
    my $time_now = scalar localtime;
    write_log_line $tfile, "$cmd [$$] [$time_now] Work file: $workfile";
    write_log_line $tfile, "$cmd [$$] [$time_now] Tar  file: $tarfile";
}

# time calculation - roughly equivalent to date +%y%m%d
{
    my ($sec, $min, $hour, $mday, $month, $year) = localtime;
    $month++;
    $timestamp = sprintf("%02d%02d%02d-%02d%02d",
                         $year, $month, $mday, $hour, $min);
}

($file = $info{dest}) =~ s|^/||o;
mkpath($push_log_dir, 0, 0755);
$push_log_file = "$push_log_dir/$file.info-$timestamp";
if ($trace & 2)
{
    write_log_line $tfile, sprintf("$cmd [$$] [%s] Detail in $push_log_file",
                                   scalar localtime);
}

#
# pick up the info file and move it
#     Moving it prevents the monitor from trying to run another process to
#     handle this data.
#
move $workfile, $push_log_file;
if (move $tarfile, $stage_dir)
{
    $tarfile =~ s|^.*/||;
    $tarfile = "$stage_dir/$tarfile";
}

chdir $stage_dir;

if (-d $file)
{
    # Hmm... the topic dir is already here...
    for (1 .. 36)
    {
        # 36 iterations with a 5-sec sleep-- give them 3 minutes to finish
        sleep 5;
        last if (! -d $file);
    }
}

#
# Check again and move things back around if the dir is still there
#
if (-d $file)
{
    move $push_log_file, "$stage_dir/$file-$timestamp.info";
    move $tarfile,       "$stage_dir/$file-$timestamp.tar";

    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] $stage_dir/$file is in use",
                           scalar localtime))
        if ($trace);
    write_log_line("$log_dir/$cmd",
                   sprintf("%s [$$] Deploy failed: Directory $stage_dir/" .
                           "$file already exists", scalar localtime));

    send_mail($error_email_list, "$cmd: Deploy failure for $file",
              [ "The uploaded package intended for project $file could not\n",
                "be deployed because the directory $stage_dir was already\n",
                "in use. The info and tar files have been preserved in:\n",
                "\n",
                "\t$stage_dir/$file-$timestamp.info\n",
                "\t$stage_dir/$file-$timestamp.tar\n",
                "\n",
                "$revision\n" ]);

    croak "Error: Directory $stage_dir/$file already in use, stopped";
}

#
# Give a heads-up on whether the content arrived in compressed form
#
if (defined $info{compressed} and ($info{compressed} =~ /^\d+$/))
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Content sent compressed (level %d)",
                           scalar localtime, $info{compressed}))
        if (($info{compressed} > 0) && ($trace & 2));
}

#
# Check the MD5 stamp if one is present. This is not yet required, but probably
# will be once the overall system is finished on both ends.
#
if (defined $info{md5} and $info{md5})
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Checking MD5 stamp on $tarfile",
                           scalar localtime))
        if ($trace & 4);

    my $signature = md5_signature $tarfile;
    if ($signature ne $info{md5})
    {
        #
        # Signatures don't match. We cannot release this content.
        #
        write_log_line($tfile,
                       sprintf("$cmd [$$] [%s] MD5 stamp did not match",
                               scalar localtime));
        if ($trace & 8)
        {
            move $push_log_file, "$stage_dir/$file-$timestamp.info";
            move ($tarfile, "$stage_dir/$file-$timestamp." .
                            ($tarfile =~ /\.tar\.gz/ ? 'tar.gz' : 'tar'));
            send_mail($error_email_list, "$cmd: Deploy failure for $file",
                      [ "The uploaded package intended for project $file was" .
                        " not deployed due to a mis-match of content\n",
                        "checksums. The files have been preserved in:\n",
                        "\n",
                        "\t$stage_dir/$file-$timestamp.info\n",
                        "\t$stage_dir/$file-$timestamp.tar\n",
                        "\n",
                        "$revision\n" ]);
        }
        else
        {
            unlink $push_log_file;
            unlink $tarfile;
            send_mail($error_email_list, "$cmd: Deploy failure for $file",
                      [ "The uplaoded package intended for project $file was" .
                        " not deployed due to a mis-match of content\n",
                        "checksums. The files have been removed.\n",
                        "\n",
                        "$revision\n" ]);
        }
        croak "Error: Checksum mismatch for $stage_dir/$file, stopped";
    }
    else
    {
        write_log_line($tfile,
                       sprintf("$cmd [$$] [%s] MD5 stamp verified",
                               scalar localtime))
            if ($trace & 3);
    }
}

# Untar the topic to be pushed
$tar = new Archive::Tar;
unless (defined $tar)
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Error creating Archive::Tar " .
                           "object: %s",
                           (scalar localtime), Archive::Tar::error));
    croak "$cmd: make_archive: Error allocating Archive::Tar object: " .
        Archive::Tar::error . "\n";
}
#
# We don't have to actually worry about the "compressed" header, since the
# Archive::Tar class auto-detects compressed content.
#
unless (defined $tar->extract_archive($tarfile))
{
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Error reading tar-file: %s",
                           (scalar localtime), Archive::Tar::error));
    croak "$cmd: make_archive: Error reading from $tarfile: " .
        Archive::Tar::error . "\n";
}

#
# At this point, safe to assume that it worked.
#
# Use process_content (or user-specified tool) to push out new data
#
# $file is the destination, minus leading /. Tar should have left a directory
# by that name in $stage_dir.
#
unless (-d $file and -x $file)
{
    send_mail($error_email_list, "$cmd: Error: No directory named $file",
              [ "The archive file $tarfile did not create ``$file'' as a\n",
                "directory in $stage_dir. Possibly a malformed package.\n",
                "\n",
                "$revision\n" ]);
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Found no directory $file in tar " .
                           "archive", (scalar localtime)))
        if ($trace);
    write_log_line("$log_dir/$cmd",
                   sprintf("%s [$$] Found no directory $file in tar archive",
                           scalar localtime));
    croak "Error: The archive file $tarfile did not create a ``$file''\n" .
        "in the directory $stage_dir. Possibly a malformed package. Stopped";
}
chdir $file;
@res_text = ("$info{name}\n", "\n");
$FH = new IO::File ">> $push_log_file";
if (! defined $FH)
{
    send_mail($error_email_list,
              "$cmd: Error opening logging file $push_log_file",
              [ "Error opening $push_log_file for appending: $!\n",
                "Package not deployed.\n",
                "\n",
                "$revision\n" ]);
    write_log_line($tfile,
                   sprintf("$cmd [$$] [%s] Error opening logging file " .
                           "$push_log_file: $!", (scalar localtime)))
        if ($trace);
    write_log_line("$log_dir/$cmd",
                   sprintf("%s [$$] Error opening $push_log_file: $!",
                           scalar localtime));
    croak "Error opening $push_log_file for appending: $!, stopped";
}

#
# Construct the command to execute, based on the value of $script and the
# command-line args that need to be carried over.
#

@command = split(/\s+/, $script);
push(@command, '-t' => $trace)   if ($trace);
push(@command, '-T' => $tfile)   if ($tfile ne '-');
push(@command, '-H' => $opts{H}) if (defined $opts{H} and $opts{H});
push(@command, '-c' => $opts{c}) if (defined $opts{c} and $opts{c});
push(@command, $mirror_group);
if ($trace & 3)
{
    write_log_line $tfile, sprintf("$cmd [$$] [%s] Running: @command",
                                   scalar localtime);
}

# Have had some problems with IO::Pipe in the past
open(PIPE, "@command 2>&1 |");

while (defined($_ = ))
{
    print $FH "Info:result\t$_";
    push(@res_text, $_);
}

close(PIPE);
if ($? >> 8)
{
    write_log_line $tfile, sprintf("$cmd [$$] [%s] Error from $command[0]: $!",
                                       scalar localtime)
        if ($trace);
    send_mail($error_email_list, "$cmd: Error from processing command",
              [ "Error from ``@command'': $!\n",
                "Package contents probably not deployed correctly.\n",
                "\n",
                "$revision\n" ]);
    chdir $stage_dir;
    rmtree $file;
    croak "Error from ``@command'': $!, stopped";
}
$FH->close;

send_mail($email_list, 'Server Data Updated', \@res_text)
    unless (defined $info{nomail} and $info{nomail} =~ /1|yes|true/o);

chdir $stage_dir;
# This routine from File::Path does a clean, recursive deletion
rmtree $file;

#
# Mirror the data if we are using an RDBMS model. If there are no mirrors,
# this routine won't do anything.
#
if (! mirror_propagate($tarfile, $mirror_group, \%info, $config,
                       ((defined $opts{c} and $opts{c}) ?
                        "$opts{c}.mir" : undef)))
{
    write_log_line $tfile, sprintf("$cmd [$$] [%s] Error trying to propagate" .
                                   " to mirrors for group $mirror_group",
                                   scalar localtime)
        if ($trace);
    write_log_line("$log_dir/$cmd",
                   sprintf("%s [$$] Unable to mirror package $tarfile.",
                           scalar localtime));
    #
    # Remove the staging directory, as we don't want to interfere with future
    # release attempts (mirrors be darned...)
    #
    chdir $stage_dir;
    unlink $tarfile;
    send_mail($error_email_list, 'Mirror Propagation Failure',
              ["Propagation of the file $tarfile to the elements of\n",
               "mirror group $mirror_group has failed. Content is only on " .
               ($opts{H} || hostfqdn) . ".\n" ]);
    croak "Error occured in mirroring the file $tarfile, stopped";
}
# remove the tar file (info file already moved)
unlink $tarfile;

write_log_line("$log_dir/$cmd",
               sprintf("%s [$$] Deployment to $info{dest} successful",
                       scalar localtime));
write_log_line("$log_dir/$cmd",
               sprintf("%s [$$] Finished",
                       scalar localtime));

exit 0;

##############################################################################
#
#   Sub Name:       read_info
#
#   Description:    Read the info file, converting the Info:xxxx lines into
#                   hash keys and trimming the input list down to all "extra"
#                   lines (which will later be treated as the checksum/
#                   signature of the tar file).
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $href     in      hashref   The hash to store key/value
#                                                 pairs in
#                   $lref     in      listref   The lines from the info file.
#                                                 On exit will be pared down to
#                                                 just the checksum lines.
#
#   Globals:        $trace
#                   $tfile
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    dies
#
##############################################################################
sub read_info


Function: read_info

Variables:

Calls:

Comments:

#!/opt/ims/perl5/bin/perl
##############################################################################
#
#                                Confidential
#             Disclosure And Distribution Solely to Employees of
#          Hewlett-Packard and Its Affiliates Having a Need to Know
#
#                  Copyright @ 1998, Hewlett-Packard, Inc.,
#                            All Rights Reserved
#
##############################################################################
#
#   @(#)$Id: deploy_content_doc.html,v 1.1 2000/05/04 21:14:28 idsweb Exp $
#
#   Description:    Take the info file passed in and manage the verification
#                   of the fields, the population of data into the staging
#                   and release areas, and effect the posting of the data to
#                   other servers in the mirror pool if requested.
#
#   Functions:      read_info
#                   send_mail
#                   mirror_propagate
#
#   Libraries:      IMS::ReleaseMgr::Signature
#                   Carp                    Core lib (better error messages)
#                   File::Copy              Core lib (smart 'mv' clone)
#                   File::Path              Core lib (emulate 'rm -rf' in Perl)
#                   Fcntl                   Core lib (flock constants)
#                   IO::File                Core lib (I/O classes)
#                   Getopt::Long            Core lib (cmd-line parsing)
#                   Sys::Hostname           Core lib (smart 'hostname' command)
#                   Net::Domain             CPAN lib for getting FQDN
#                   Mail::Internet          CPAN lib for sending UNIX mail
#                   Mail::Header              part of the above
#                   LWP::UserAgent          \
#                   HTTP::Request::Common    > CPAN libs, used for mirroring
#                   URI::URL                /
#
#   Global Consts:  $cmd                    This tool's name
#                   $USAGE                  The tool usage error message
#
#   Environment:    PATH                    This has to be trimmed drastically
#                                             for security
#
##############################################################################
$VERSION = do {my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d"x$#r,@r};;
#
# The Archive::Tar package handles compression automatically. However, that
# means that the file could possibly arrive with a ".gz" suffix to the name.
# Later, when deriving the tarfile name, we only want to accept that suffix
# as a contender if this mirror is configured to use compression.
#
    #
    # Set up a file for tracing to write to. In absence of -T, we use STDOUT
    #
if ($trace & 8) # bxxxx1xxx
# Make sure that the argument the program was called with is
# actually a name of a file present in the either $stage_dir or $incoming_dir.
# If not, exit with an error message.
# Parse the lines into hash keys, leave only the old-style digital signature
# (if present) in @info:
# Take the argument, delete the part of the path which denotes the directory
# and the suffix ".info".
# If the tarred file is not there, exit with an error message
# time calculation - roughly equivalent to date +%y%m%d
#
# pick up the info file and move it
#     Moving it prevents the monitor from trying to run another process to
#     handle this data.
#
    # Hmm... the topic dir is already here...
        # 36 iterations with a 5-sec sleep-- give them 3 minutes to finish
#
# Check again and move things back around if the dir is still there
#
#
# Give a heads-up on whether the content arrived in compressed form
#
#
# Check the MD5 stamp if one is present. This is not yet required, but probably
# will be once the overall system is finished on both ends.
#
        #
        # Signatures don't match. We cannot release this content.
        #
# Untar the topic to be pushed
#
# We don't have to actually worry about the "compressed" header, since the
# Archive::Tar class auto-detects compressed content.
#
#
# At this point, safe to assume that it worked.
#
# Use process_content (or user-specified tool) to push out new data
#
# $file is the destination, minus leading /. Tar should have left a directory
# by that name in $stage_dir.
#
#
# Construct the command to execute, based on the value of $script and the
# command-line args that need to be carried over.
#
# Have had some problems with IO::Pipe in the past
# This routine from File::Path does a clean, recursive deletion
#
# Mirror the data if we are using an RDBMS model. If there are no mirrors,
# this routine won't do anything.
#
    #
    # Remove the staging directory, as we don't want to interfere with future
    # release attempts (mirrors be darned...)
    #
# remove the tar file (info file already moved)
##############################################################################
#
#   Sub Name:       read_info
#
#   Description:    Read the info file, converting the Info:xxxx lines into
#                   hash keys and trimming the input list down to all "extra"
#                   lines (which will later be treated as the checksum/
#                   signature of the tar file).
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $href     in      hashref   The hash to store key/value
#                                                 pairs in
#                   $lref     in      listref   The lines from the info file.
#                                                 On exit will be pared down to
#                                                 just the checksum lines.
#
#   Globals:        $trace
#                   $tfile
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    dies
#
##############################################################################/n/n         # Skip comments (blanks might be allowed in @remnants, though)
        next if $line =~ /^\#/o;
        if ($line =~ /^Info:/o) # Typical content
    #
    # Return the listref containing only those lines we didn't use
    #

Code:

{
    my ($href, $lref) = @_;

    my (@remnants, $line, $key, $value);

    for $line (@{$lref})
    {
        # Skip comments (blanks might be allowed in @remnants, though)
        next if $line =~ /^\#/o;

        if ($line =~ /^Info:/o) # Typical content
        {
            ($key, $value) = split(/\s+/, $line, 2);
            $key =~ s/^Info://o;
            $href->{$key} = $value;
        }
        else
        {
            push(@remnants, $line);
        }
    }

    if ($trace & 4)
    {
        for $key (sort keys %{$href})
        {
            write_log_line($tfile, "$cmd [$$] [read_info] $key=$href->{$key}")
        }
    }

    #
    # Return the listref containing only those lines we didn't use
    #
    @{$lref} = @remnants;
    1;
}


Function: mirror_propagate

Variables:

Calls:

Comments:

##############################################################################
#
#   Sub Name:       mirror_propagate
#
#   Description:    Query the RDBMS for the other hosts that are a part of this
#                   mirror pool. Use the upload URL to propagate the tar file
#                   to the other hosts.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $file     in      scalar    Pathname of the tar file
#                   $mirror   in      scalar    Name of the mirror group
#                   $info     in      hashref   Reference to the infofile vals
#                   $config   in      hashref   Ref to the configuration vals
#        (optional) $hostfile in      scalar    If passed, name of the file to
#                                                 read mirror host list from
#
#   Globals:        $cmd
#                   $basedir
#
#   Environment:    None.
#
#   Returns:        Success:    1
#                   Failure:    0
#
##############################################################################/n/n     #
    # Nasty loops happen if we don't clear this
    #
    # Get this machine's fully-qualified hostname + domain
    else # ftp
        # Not *really* an error

Code:

{
    my ($file, $mirror, $info, $config, $hostfile) = @_;

    my ($hostlist, $FQDN, $host, $URI, $UA, $project, $res, $bad, $error_list);

    return 1 unless
        (defined $info->{upload} and ($info->{upload} =~ /1|yes|true/i));

    #
    # Nasty loops happen if we don't clear this
    #
    $info->{upload} = 'no';

    if (defined $hostfile and $hostfile)
    {
        $hostlist = file_mirror_host_list(-file => $hostfile);
        unless (defined $hostlist)
        {
            write_log_line($tfile,
                           sprintf("$cmd [$$] [%s] Error getting mirror list" .
                                   " from file: %s",
                                   scalar localtime, file_error))
                if ($trace);
            write_log_line("$log_dir/$cmd",
                           sprintf("%s [$$] Error getting mirror list from " .
                                   "file: %s",
                                   scalar localtime, file_error));
            carp "$cmd was unable to get data for $mirror_group from file " .
                "$hostfile, stopping";
            return 0;
        }
    }
    else
    {
        $hostlist = DBI_mirror_host_list(-mirror => $mirror_group);
        unless (defined $hostlist)
        {
            write_log_line($tfile,
                           sprintf("$cmd [$$] [%s] Error getting mirror list" .
                                   " from DBI: %s",
                                   (scalar localtime), DBI_error))
                if ($trace);
            write_log_line("$log_dir/$cmd",
                           sprintf("%s [$$] Error getting mirror list from " .
                                   "DBI: %s",
                                   scalar localtime, DBI_error));
            carp "$cmd was unable to get data for $mirror_group from " .
                "Oracle, stopping";
            return 0;
        }
    }

    return 1 unless ((scalar @$hostlist) > 1);

    # Get this machine's fully-qualified hostname + domain
    $FQDN = $opts{H} || hostfqdn;
    ($project = $info->{dest}) =~ s|^/||o;

    if ($info->{transport} eq 'http')
    {
        ($res, $bad, $error_list) = mirror_upload($file, $project, $FQDN,
                                                  $hostlist, $config, $info);

        if (! $res)
        {
            my $date = scalar localtime;

            for $host (@$bad)
            {
                $res = shift(@$error_list);

                write_log_line("$log_dir/$cmd",
                               "$date [$$] Mirror FAILED to host $host: $res");
                write_log_line("$tfile",
                               "$cmd [$$] [$date] Mirroring FAILED to host " .
                               "$host: $res")
                    if ($trace);
            }

            return 0;
        }
    }
    else # ftp
    {
        my $date = scalar localtime;

        write_log_line("$log_dir/$cmd",
                       "$date [$$] FTP mirroring should be done by client");
        write_log_line("$tfile",
                       "$cmd [$$] [$date] FTP mirroring is not supported at " .
                       "the server level")
            if ($trace);

        # Not *really* an error
        return 1;
    }

    1;
}