#!/usr/bin/perl
######################################################################
#
# Tool to manage experiment tags
#
# Author: Andrea Sciaba' <Andrea.Sciaba@cern.ch>
#
# Version: 0.4.2
#
# History:
# - 0.4.2: now --help returns exit status 0
# - 0.4.1: now returns exit status 1 if cannot read tags
# - 0.4.0: full support for https PUT
# - 0.3.0: adds support for RTEPublisher
# - 0.2.3: no more temp files left around, some globus error messages
#          suppressed
# - 0.2.2: improved error messages; fixed file permissions if pool accounts
#          are used
# - 0.2.1: added '.' to the list of allowrd characters in tags
# - 0.2.0: added the possibility to extract the VO from the proxy or from
#          LCG_GFAL_VO; extended allowed character set in tags; retry
#          mechanism for new tag upload with dump to a file if failed 3
#          times; better cleanup of temporary files
# - 0.1.0 : First version
######################################################################

use Getopt::Long;
use Net::LDAP;
use Net::LDAP::Message;
use Net::LDAP::Filter;
use Pod::Usage;
use File::Temp qw/tempfile mktemp/;

$NAME='lcg-tags';
$VERSION='0.4.1';

GetOptions(
	   'help'      => \$help,
	   'bdii=s'    => \$bdii,
	   'ce=s'      => \$ce,
	   'sc=s'      => \$sc,
	   'vo=s'      => \$vo,
	   'tags=s'    => \@tags,
	   'tagfile=s' => \$tagfile,
	   'add'       => \$add,
	   'replace'   => \$replace,
	   'remove'    => \$remove,
	   'clean'     => \$clean,
	   'debug'     => \$debug,
	   'verbose'   => \$verbose,
	   'version'   => \$version,
	   'list'      => \$list,
	   ) or pod2usage("Syntax error.");
pod2usage(-verbose => 2,
          -exitval => 0) if $help;
pod2usage("Syntax error.") if (@ARGV > 0);

$exitstatus = 0;

if ($version) {
    print "$NAME version $VERSION\n";
    exit 0;
}
if (!($ce || $sc)) { die "$NAME: error: CE host name or SubCluster name not specified.\n" };
if ($ce && $sc) { die "$NAME: error: must specify either --ce or --sc.\n" };
$vo = &find_vo if (!$vo);
if (!$vo) {
    die "$NAME: error: could not find VO name in command line, in proxy or in LCG_GFAL_VO.\n";
}
if ($add+$replace+$remove+$clean+$list != 1) {
    die "$NAME: error: use --add, --replace, --remove, --clean or --list.\n";
}
if (($add || $replace || $remove) && !(@tags || $tagfile)) { die "$NAME: error: list of tags not provided.\n" };
print "VO: $vo\n" if ($debug);

@tags = split(/,/, join(',', @tags));
if ($tagfile) {
    push @tags, &read_tagfile($tagfile);
}

# BDII server
if ($sc) {
    if (!$bdii) {
	$bdii = $ENV{LCG_GFAL_INFOSYS} or die("$NAME: LCG_GFAL_INFOSYS undefined.\n");
    }
}
@bdiilist = split /,/, $bdii;

&check_proxy;
&check_tags(@tags);

if ($ce) {
#    if (!($ce =~ /\./)) {
#	warn "$NAME: error: use a fully qualified host name\n";
#	exit 1;
#    }
    $endpoint = &remotepath($ce);
} elsif ($sc) {
    $endpoint = &remotepathsc($sc);
}
die "$NAME: error: could not locate the service endpoint in the BDII.\n" if (!$endpoint);
warn "Endpoint: $endpoint\n" if ($debug);

&addtags if ($add || $replace);
&removetags if ($remove);
&cleantags if ($clean);
&listtags if ($list);

exit $exitstatus;

#
# Finds the VO from the proxy or from LCG_GFAL_INFOSYS
#
sub find_vo {
    my $cmd = "voms-proxy-info -vo 2> /dev/null | head -1 ";
    my $vo = `$cmd`;
    chomp $vo;
    if (!$vo) {
	$vo = $ENV{"LCG_GFAL_VO"};
    }
    return $vo;
}

#
# Checks that there is a valid proxy
#
sub check_proxy {
    my $cmd = "grid-proxy-info -exists 2> /dev/null";
    if (system("$cmd")) {
	die "$NAME: error: could not find a valid proxy.\n";
    }
    $ENV{X509_USER_PROXY} = `grid-proxy-info -path`;
    chomp $ENV{X509_USER_PROXY};
    if (!$ENV{X509_CERT_DIR}) {
	$ENV{X509_CERT_DIR} = '/etc/grid-security/certificates';
    }
}

#
# Reads tags from file
#
sub read_tagfile {
    my $tagfile = shift;
    open(TAGS, "$tagfile") or die "$NAME: error: tag file $tagfile does not exist.\n";
    my @list = <TAGS>;
    my @tags = grep { /.+/ } map { split /\s+/ } @list;
    close TAGS;
    return @tags;
}

#
# Adds tags
#    
sub addtags {
    my @oldtags = ();
    @oldtags = &read_tags($vo, $endpoint) if ($add);
    my @newtags = sort(&remove_dup(@oldtags, @tags));
    if (@newtags > @oldtags) {
	&write_tags($vo, $endpoint, @newtags);
    } else {
	warn "$NAME: warning: tags already present.\n";
    }
}

#
# Removes tags
#
sub removetags {
    my @oldtags = &read_tags($vo, $endpoint);
    my @newtags = ();
    foreach my $o (@oldtags) {
	push(@newtags, $o) if (!grep($o eq $_, @tags));
    }
    if (@newtags < @oldtags) {
	&write_tags($vo, $endpoint, @newtags);
    } else {
	warn "$NAME: warning: no tags to remove.\n";
    }
}

#
# Cleans tags
#
sub cleantags {
    &write_tags($vo, $endpoint, ());
}

#
# Lists tags
#
sub listtags {
    my @oldtags = &read_tags($vo, $endpoint);
    foreach (@oldtags) {
        print "$_\n";
    }
}

#
# Get remote endpoint from CE
#
sub remotepath {
    my $ce = shift;
    my $endpoint = '';
    my $edgvar = '';
    my $temp = mktemp("/tmp/lcg-tagsXXXXXX");
    my $sysedg = "gsiftp://$ce/etc/sysconfig/edg";
    my $cmd = `globus-url-copy $sysedg file://$temp 2>&1`;
    if ($cmd) {
	unlink $temp;
	die "$NAME: error: cannot download /etc/sysconfig/edg from CE.\n" .
	    "$NAME: error: " . &guc_error($cmd, $verbose) . "\n";
    }
    open(TMP, "$temp") or die "$NAME: error: cannot open file $temp.\n";
    while (<TMP>) {
	chomp;
	my ($key, $value) = split /=/, $_;
	if ($key eq 'EDG_LOCATION_VAR') {
	    $edgvar = $value;
	    last;
	} elsif ($key eq 'EDG_LOCATION') {
	    $edgvar = "$value/var";
	}
    }
    close TMP;
    unlink $temp;
    $endpoint = "gsiftp://$ce$edgvar/info/$vo";
    return $endpoint;
}

#
# Get remote endpoint from BDII
#
sub remotepathsc {
    my $sc = shift;
    my $edgvar = '';
    my $temp = mktemp("/tmp/lcg-tagsXXXXXX");

# Open the connection to the BDII
    &bdii_init;
    print "BDII: $bdii\n" if ($debug);

# Search the BDII for the Objects
    my $base = 'o=grid';
    my $filter = "(GlueServiceDataKey=GlueSubClusterUniqueID:$sc)";
    my $mesg = $ldap->search(base   => $base,
			     filter => $filter);
    if ( $mesg->is_error() ) {
	$ldap->unbind();
	die ("$NAME: error: error searching the BDII:\n$mesg->error()\n");
    }

# Get the Objects
    my $service = '';
    my $endpoint = '';
    foreach my $entry ( $mesg->entries() ) {
	warn "$NAME: warning: more than one RTE service found.\n"
	    if ($service);
	$service = $entry->get_value('GlueChunkKey');
    }
    $service =~ s/.*=//;
    $filter = "(&(GlueServiceType=org.glite.RTEPublisher)(GlueServiceUniqueID=$service))";
    $mesg = $ldap->search(base   => $base,
			     filter => $filter);
    if ( $mesg->is_error() ) {
	$ldap->unbind();
	die ("$NAME: error: error searching the BDII:\n$mesg->error()\n");
    }
    foreach my $entry ( $mesg->entries() ) {
	$endpoint = $entry->get_value('GlueServiceEndpoint');
    }
    if (! $endpoint) {
	return $endpoint;
    }
    $endpoint .= "/$sc/$vo";
    $ldap->unbind();
    return $endpoint;
}

#
# Check that tags are correctly defined
#
sub check_tags {
    my @tags = @_;
    foreach (@tags) {
	if (/[^\w\.\-_:\/]/) {
	    die "$NAME: error: illegal character in tag name $_.\n";
	} elsif (!/^VO-$vo-\w+/) {
	    die "$NAME: error: illegal tag syntax: use VO-<voname>-<text>.\n";
	}
    }
}

#
# Read tags from remote file
#
sub read_tags {
    my $vo = shift;
    my $endpoint = shift;
    my @tags = ();
    my $temp = mktemp("/tmp/lcg-tagsXXXXXX");
    my $listfile = $endpoint . "/$vo.list";
    my $cmd;
    if (&remotecopy($listfile, $temp)) {
	warn "$NAME: warning: failed to download $listfile. Maybe it does not exist.\n";
	$exitstatus = 1;
	unlink $temp;
	return @tags;
    }
    open(TMP, "$temp") or die "$NAME: error: cannot open file $temp.\n";
    my @list = <TMP>;
    return () if grep(/Not Found/, @list);
    @tags = grep { /.+/ } map { split /\s+/ } @list;
    close TMP;
    unlink $temp;
    return sort @tags;
}

#
# Write tags to remote file
#
sub write_tags {
    my $vo     = shift;
    my $endpoint = shift;
    my @tags   = @_;
    my ($fh, $temp) = tempfile()
	or die "$NAME: error: cannot create file $temp.\n";
    foreach (@tags) {
	print $fh "$_\n";
    }
    close $fh;
    my $ret = &lock_file($vo, $endpoint);
    if ($ret) {
	unlink $temp;
	die "$NAME: error: cannot create remote lockfile.\n"
	}
    my $listfile = $endpoint . "/$vo.list";
    my $cmd;
    my $retries = 0;
    while (&remotecopy($temp, $listfile) && $retries < 3) {
	sleep 10;
	$retries++;
    }
    if ($retries == 3) {
	system("mv -f $temp failed.tags");
	warn "$NAME: error: new tag upload failed. New tags dumped in failed.tags\n";
    } else {
	if ($endpoint =~ /^gsiftp/) {
	    if ( &is_poolaccount(&whoami($endpoint)) ) {
		&fix_perm($ce, "$edgvar/info/$vo", "0775");
		&fix_perm($ce, "$edgvar/info/$vo/$vo.list", "0664");
	    }
	}
    }
    &unlock_file($vo, $endpoint);
    unlink $temp if (-e $temp);
}

#
# Creates lock file on remote server
#
sub lock_file {
    my $vo = shift;
    my $endpoint = shift;
    my $lockfile = $endpoint . "/lock";

# If endpoint is https disable lock file
    return 0 if ($endpoint =~ /^https/);

    my $temp = mktemp("/tmp/lcg-tagsXXXXXX");
    my $ret = &remotecopy($lockfile, $temp);

# Exit with error status if could get a lock file
    if (!$ret) {
	unlink $temp;
	warn "$NAME: error: lock file already present at $lockfile.\n";
	return 1;
    }
    unlink $temp;
    my ($fh, $temp) = tempfile();
    if (!defined $fh) {
	    warn "$NAME: error: cannot create file $temp.\n";
	    return 1;
	};
    my $name = getlogin() || (getpwuid($<))[0];
    my $ip = `hostname -i`;
    my @date = gmtime(time);
    my $year = $date[5]+1900;
    my $date = "$date[3]-$date[4]-$year $date[2]:$date[1]:$date[0]";
    print $fh <<"EOF";
Lock file generated by $name from $ip at $date.
EOF
    close $fh;

# Create lock file in CE and die if fails
    my $ret = &remotecopy($temp, $lockfile);
    unlink $temp;
    if ($ret) {
	return 1;
    }
    return 0;
}

#
# Removes lock file from remote server (only GridFTP)
#
sub unlock_file {
    my $vo     = shift;
    my $endpoint = shift;

# If endpoint is https disable lock file
    return 0 if ($endpoint =~ /^https/);

    my $lockfile = $endpoint . "/lock";
    my $ret = &remoterm($lockfile);
    if ($ret) {
	die "$NAME: error: cannot unlock the tag file.\n";
    }
}

#
# Removes duplicate items in an array
#
sub remove_dup {
    my @a;
    foreach my $i ( @_ ) {
	my $is = 0;
	foreach my $j ( @a ) {
	    $is = 1 if $i eq $j;
	}
	push (@a, $i) if not $is;
    }
    return @a;
}

#
# Writes globus-url-copy errors in a user-friendly format
#
sub guc_error {
    my $reason = shift;
    my $verbosity = shift;
    my %Reasons = (
		   'globus_libc_gethostbyname_r failed' =>
		   'The CE does not exist',
		   'globus_libc_getaddrinfo failed' =>
		   'The CE does not exist',
		   'globus_libc_gethostbyaddr_r failed' =>
		   'The CE does not exist',
		   'LCMAPS credential mapping NOT successful' =>
		   'you are not authorized on the CE.',
		   'Permission denied' =>
		   'you do not have the privileges to read',
		   'No such file or directory' =>
		   'no such file or directory',
		   'not a plain file' =>
		   'the file does not exist',
		   'Valid credentials could not be found' =>
		   'valid credentials could not be found'
		   );
    my $code = $reason;
    foreach ( keys %Reasons ) {
        if ( $code =~ /$_/ ) {
            $code = $Reasons{$_};
        }
    }
    $code = $code . "\n" . $reason if ( $verbosity && $code ne $reason );
    return $code;
}

#
# Changes permissions of remote file (only GridFTP)
#
sub fix_perm {
    my $node = shift;
    my $file = shift;
    my $perm = shift;

    my $cmd = "uberftp $node \'chmod $perm $file\' > /dev/null 2>&1";
    return system("$cmd");
}

#
# Finds local account to which the user is mapped (only GridFTP)
#
sub whoami {
    my $endpoint = shift;
    if ($endpoint =~ /^gsiftp:\/\/(.+?):/ or
	$endpoint =~ /^gsiftp:\/\/(.+?)\//) {
	my $node = $1;
	my $user = '';
	my $cmd = "uberftp $node bye";
	my @output = `$cmd`;
	foreach (@output) {
	    $user = $1 if ( /User (.+) logged in/ );
	}
	return $user;
    } else {
	warn "$NAME: whoami not supported for $endpoint\n";
	return undef;
    }
}

#
# Tests if username is a pool account by looking for numbers at the end
#
sub is_poolaccount {
    my $user = shift;
    return $user =~ /\d+$/;
}    

#
# Opens a connection to the BDII
#
sub bdii_init {

    foreach my $bdii (@bdiilist) {
	unless ($ldap = Net::LDAP->new($bdii)) {
	    warn("$NAME: failed to contact BDII $bdii.\n");
	    next;
	}
	$mesg = $ldap->bind;
	if ($mesg->is_error()) {
	    warn("$NAME: warning: error in binding the BDII:\n$mesg->error_text().\n");
	    next;
	} else {
	    return 0;
	}
    }
    die("$NAME: error in contacting all BDII.\n");
}

#
# Copy a local file to the remote server or viceversa
#
sub remotecopy {
    my $source = shift;
    my $dest = shift;
    my $stype = 'file';
    my $dtype = 'file';
    my $cmd;
    $stype = 'gsi' if ($source =~ /^gsiftp/);
    $dtype = 'gsi' if ($dest =~ /^gsiftp/);
    $stype = 'https' if ($source =~ /^https/);
    $dtype = 'https' if ($dest =~ /^https/);
    if ($stype eq 'file' and $dtype eq 'gsi') {
	$cmd = "globus-url-copy file://$source $dest > /dev/null 2>&1";
    } elsif ($stype eq 'gsi' and $dtype eq 'file') {
	$cmd = "globus-url-copy $source file://$dest  > /dev/null 2>&1";
    } elsif ($stype eq 'file' and $dtype eq 'https') {
	$cmd = "curl -s --capath \$X509_CERT_DIR --cert \$X509_USER_PROXY --key \$X509_USER_PROXY --upload $source $dest";
    } elsif ($stype eq 'https' and $dtype eq 'file') {
	$cmd = "curl -s --capath \$X509_CERT_DIR --cert \$X509_USER_PROXY --key \$X509_USER_PROXY $source -o $dest";
    } else {
	if ($debug) {
	    warn "$NAME: remote copy from $source to $dest not supported\n";
	}
	return 1;
    }
    my $ret = system("$cmd");

# If destination is a local file consider failure if it contains "Not Found"
    if (!$ret and $dtype eq 'file') {

# Touch the file to create it empty if it does not exist
	system("touch $dest");
	open(FILE, $dest);
	my @content = <FILE>;
	$ret = 1 if grep(/Not Found/, @content);
	close FILE;
    }
    if ($ret) {
	if ($debug) {
	    warn "$NAME: remote copy from $source to $dest failed\n";
	}
	return 1;
    }
    return 0;
}

#
# Remove a file on the remote server
#
sub remoterm {
    my $file = shift;
    my $cmd;
    my $host;
    my $port;
    my $path;
    if ($file =~ /^gsiftp:\/\/(.+?):(.+?)(\/.*)$/) {
	$host = $1;
	$port = $2;
	$path = $3;
	$cmd = "uberftp $host -P $port \"rm $path\" > /dev/null 2>&1";
    } elsif ($file =~ /^gsiftp:\/\/(.+?)(\/.*)$/) {
	$host = $1;
	$port = 2811;
	$path = $2;
	$cmd = "uberftp $host -P $port \"rm $path\" > /dev/null 2>&1";
    } elsif ($file =~ /^https/) {
	$cmd = "curl -s --capath \$X509_CERT_DIR --cert \$X509_USER_PROXY --key \$X509_USER_PROXY -X DELETE $file";
    } else {
	warn "$NAME: remote rm on $file not supported";
	return 1;
    }
    if (system("$cmd")) {
	return 1;
    }
    return 0;
}

__END__

=pod

=head1 NAME

lcg-tags - manage experiment tags

=head1 SYNOPSIS

Add tags:

B<lcg-tags> --ce I<cehost>|--sc I<subcluster> --vo I<voname> --add --tags I<tags> --tagfile I<tagfile>

Replace tags:

B<lcg-tags> --ce I<cehost>|--sc I<subcluster> --vo I<voname> --replace --tags I<tags> --tagfile I<tagfile>

Remove tags:

B<lcg-tags> --ce I<cehost>|--sc I<subcluster> --vo I<voname> --remove --tags I<tags> --tagfile I<tagfile>

Clean tags:

B<lcg-tags> --ce I<cehost>|--sc I<subcluster> --vo I<voname> --clean

List tags:

B<lcg-tags> --ce I<cehost>|--sc I<subcluster> --vo I<voname> --list

Prints help:

B<lcg-tags> --help

=head1 DESCRIPTION

This command allows an experiment software manager (ESM) to change the values
of the GlueHostApplicationSoftwareRunTimeEnvironment attribute for a selected
Computing Element or SubCluster and his Virtual Organisation. The ESM must
have a valid VOMS proxy with the proper role.

=head1 OPTIONS

=head2 General options

=over 8

=item B<--ce> I<cehost>

Specifies the host name of the Computing Element head node.

=item B<--sc> I<subcluster>

Specifies the Glue name of a GlueSubCluster.

=item B<--vo> I<voname>

Specifies the name of the Virtual Organisation. If not specified, the
command tries to extract the VO from the user proxy certificate, or from the
value of the environment variable LCG_GFAL_VO.

=back


=head2 Actions

=over 8

=item B<--add>

Adds the specified tags to the existing tags.

=item B<--replace>

Replaces the existing tags with the specified tags.

=item B<--remove>

Removes the specified tags from the existing tags.

=item B<--clean>

Deletes all the existing tags.

=item B<--list>

Prints the existing tags.

=item B<--help>

Prints this help.

=back

=head2 Tags

Tags must follow this syntax:

VO-I<voname>-I<text>

where I<voname> is the name of the Virtual Organisation and I<text> is
an arbitrary string containing only letters, numbers and the characters .-_/:.
Tags can be specified by the following options:

=over 8

=item B<--tags> I<tag1,tag2,...>

Specifies the tags to be added or removed as a comma-delimited list
(no spaces allowed). Multiple --tags options can be given.

=item B<--tagfile> I<tagfile>

Specifies a file containing a list of tags to be added or removed. The
tags can be separated by any number of spaces, tabs and newlines.

=back


=head2 Other options

=over 8

=item B<--debug>

Prints the endpoint contacted.

=item B<--verbose>

Prints verbose globus-url-copy error messages.

=item B<--version>

Prints the version number.

=head1 KNOWN BUGS

None.

=head1 AUTHOR

Written by Andrea Sciaba.

=head1 REPORTING BUGS

Submit bugs to <Andrea.Sciaba@cern.ch>.

=cut
