#!/usr/bin/env perl
#
# small daemon process to maintain GT4 delegations to remote sites
# on behalf of a single user account and submit machine. The daemon
# will go away by itself 2 hours before the user certificate expires.
#
# This file or a portion of this file is licensed under the terms of
# the Globus Toolkit Public License, found in file GTPL, or at
# http://www.globus.org/toolkit/download/license.html. This notice must
# appear in redistributions of this file, with or without modification.
#
# Redistributions of this Software, with or without modification, must
# reproduce the GTPL in: (1) the Software, or (2) the Documentation or
# some other similar material which is provided with the Software (if
# any).
#
# Copyright 1999-2004 University of Chicago and The University of
# Southern California. All rights reserved.
#
# Author: Jens-S. Vckler   voeckler at cs dot uchicago dot edu
# $Id$
#
use 5.006;
use strict;
use subs qw(log);		# replace Perl's math log with logging
use POSIX qw(setsid);
use File::Spec;
use File::Basename qw(basename);
use Getopt::Long qw(:config bundling no_ignore_case);
use Socket;
use Carp;
use Data::Dumper;

# non-standard modules
use Time::HiRes qw(time);
use File::Temp qw(tempfile);
use URI;

# our modules
use Work::Common;
use Euryale::Delegation qw(parse_epr);

# constants
$main::DEBUG = 1;		# for now
$main::parent = $$;		# us
my $workdir = '/tmp';		# where the daemon lives
my $margin = 7200;		# safety margin in seconds
my $uuid_re = '([[:xdigit:]]{8}(?:-[[:xdigit:]]{4}){3}-[[:xdigit:]]{12})';

# revision handling
$_ = '$Revision$';      # don't edit, automatically updated by CVS
$main::revision=$1 if /Revision:\s+([0-9.]+)/;

# forward declarations
sub usage;			# { }
sub globus_app($);		# { }

my $nodaemon = 0;		# foreground mode
my $family = 'inet';		# UNIX, LOCAL, INET
my $socket = 0;			# port number (INET) or filename (UNIX)
GetOptions( "help|h" => \&usage,
	    "debug|d+" => \$main::DEBUG,
	    "family|F=s" => sub { $family = lc($_[1]) },
	    "bind|B=s" => \$socket, 
	    "no-daemon|n" => sub { $nodaemon=1 },
	    "foreground|N" => sub { $nodaemon=2 } );

# filenames
my $logfile = File::Spec->catfile( $workdir, "vdd-$>.log" );
$logfile = File::Spec->rel2abs( $logfile );

my $sockfn = File::Spec->catfile( $workdir, "vdd-$>.sock" );
$sockfn =  File::Spec->rel2abs( $sockfn );
die "ERROR: $sockfn exists, some instance is already running!\n"
    if ( -S $sockfn || -f _ );

my $tempfn = "vdd-$>-XXXXXX";

# sanity checks
die "ERROR: GLOBUS_LOCATION is not set\n" 
    unless exists $ENV{'GLOBUS_LOCATION'};

# applications we will run
my $gpi = globus_app( 'grid-proxy-info' );
my $gcd = globus_app( 'globus-credential-delegate' );
my $gcr = globus_app( 'globus-credential-refresh' );
my $wsd = globus_app( 'wsrf-destroy' );

#
# --- functions ---------------------------------------------------
#

sub usage {
    my $base = basename($0, '.pl');
    print << "EOF";

Usage: $base [options] 

Optional arguments:
 -h|--help       print this help and exit.
 -d|--debug      accumulative, add more messages as repeated, default level $main::DEBUG
                 dynamic adjustments via signals USR1 (incr) and USR2 (decr).
 -n|--no-daemon  (debug) don\'t daemonize $base; keep it in the foreground.
 -N|--foreground (Condor) don\'t daemonize $base; go through motions as if.
 -F|--family f   protocol family: Either inet or unix (local), default $family.
 -B|--bind bind  socket filename for unix, or listening port for inet. 

EOF
    exit(1);
}

sub log {
    # purpose: print whatever onto log stream with timestamp prefix
    # paramtr: any number of more parameters
    # returns: -
    my @now = Time::HiRes::gettimeofday();
    my @tm = localtime( $now[0] );
    my $prefix = sprintf( "%4d%02d%02dT%02d%02d%02d.%03d: ",
                          $tm[5]+1900, $tm[4]+1, $tm[3],
                          $tm[2], $tm[1], $tm[0], $now[1] / 1000 );
    syswrite( STDOUT, $prefix . join('',@_) . "\n" );
}

sub fatal {
    # purpose: log plus exit with failure
    # paramtr: any number of more parameters
    # returns: does not return 
    if ( $! != 0 ) {
	log( 'FATAL: ', @_, ": $!" );
    } else {
	log( 'FATAL: ', @_ );
    }
    exit(42);
}

sub show_sockaddr ($) {
    # purpose: translate a socket address into something symbolic
    # paramtr: $sa (IN): socket address to translate
    # returns: string of translation
    my $sa = shift;
    my $family = sockaddr_family($sa);
    if ( $family == AF_INET ) {
	my ($port,$host) = unpack_sockaddr_in($sa);
	return inet_ntoa($host) . ':' . $port;
    } elsif ( $family == AF_UNIX ) {
	return unpack_sockaddr_un($sa);
    } else {
	fatal( 'Illegal socket address family', $family );
    }
}

sub create_socket_un ($) {
    # purpose: Open a server socket to listen on
    # paramtr: $sockfn (IN): filename to bind socket on
    # returns: socket descriptor
    local(*SOCK);
    my $sockfn = shift || croak "ERROR: Need a socket name";
    socket( SOCK, PF_UNIX, SOCK_STREAM, 0 ) || 
	fatal( 'socket( PF_UNIX, SOCK_STREAM )' );
    setsockopt( SOCK, SOL_SOCKET, SO_REUSEADDR, pack('l',1) ) ||
	fatal( 'setsockopt(SO_REUSEADDR)' );
    bind( SOCK, pack_sockaddr_un($sockfn) ) ||
	fatal( 'bind($sockfn)' );
    listen( SOCK, SOMAXCONN ) ||
	fatal( 'listen(SOMAXCONN)' );
    return *SOCK;
}

sub create_socket_in ($;$) {
    # purpose: Open a server socket to listen on
    # paramtr: $port (IN): port to bind to 
    #          $host (opt. IN): opaque string with host addr to bind to 
    # returns: socket descriptor
    local(*SOCK);
    my $port = shift;
    my $host = shift || INADDR_ANY;

    my $proto = getprotobyname('tcp') ||
	fatal( 'getprotobyname(tcp)' );
    socket( SOCK, PF_INET, SOCK_STREAM, $proto ) || 
	fatal( 'socket( PF_UNIX, SOCK_STREAM )' );
    setsockopt( SOCK, SOL_SOCKET, SO_REUSEADDR, pack('l',1) ) ||
	fatal( 'setsockopt(SO_REUSEADDR)' );
    if ( defined $host || defined $port ) {
	# FIXME: obey GTPR if port==0
	bind( SOCK, pack_sockaddr_in($port,$host) ) ||
	    fatal( 'bind($sockfn)' );
    }
    listen( SOCK, SOMAXCONN ) ||
	fatal( 'listen(SOMAXCONN)' );

    # tell users where do we listen for internet sockets
    my $oldmask = umask( 0077 );
    if ( open( OUT, ">$sockfn" ) ) {
	chmod 0600, $sockfn;
	print OUT show_sockaddr( getsockname(SOCK) ), "\n";
	close OUT;
    } else {
	log( "Warning: Unable to write to $sockfn" );
    }
    umask($oldmask);
    return *SOCK;
}

sub finish_socket (*) {
    # purpose: Done with server socket
    # paramtr: $sock (IN): socket file handle scalar
    local(*SOCK) = shift;
    close(SOCK);
    unlink $sockfn;
}

sub globus_app($) {
    # purpose: Check location of a globus application
    # paramtr: $app (IN): basename of application
    # returns: full name of application, dies if unavailable
    my $app = shift;
    my $fn = File::Spec->catfile( $ENV{'GLOBUS_LOCATION'}, 'bin', $app );
    $fn = find_exec($app) unless ( -r $fn && -x _ );
    die "ERROR: Unable to execute $app\n" 
	unless ( defined $fn && -r $fn && -x _ );
    $fn;
}

sub get_user_time() {
    # purpose: obtains the remaining time on the user certificate
    # globals: $gpi (IN): path to globus-proxy-info
    # returns: time remaining, or 0 and -1 to indicate errors.
    log( 'checking remaining time on user proxy' );
    my @result = pipe_out_cmd( $gpi, '-timeleft' );
    return -1 if ( $? != 0 );
    return 0 if ( @result == 0 );
    $result[0]+0;
}

sub canonical($) {
    # purpose: Extracts hostname and port, and returns canonical dotted quad
    # paramtr: $uri (IN): URI to extract information from
    # returns: canonical expression
    my $x = shift;
    my $uri = substr(ref($x),0,3) eq 'URI' ? $x : URI->new($x);
    my $port = $uri->port;
    my $addr = inet_aton( $uri->host );
    my $host = defined $addr ? inet_ntoa( $addr ) : $uri->host;
    "$host:$port";
}

sub show_error($$\@) {
    # purpose: show the error output, but only part
    # paramtr: $rc (IN): raw wait status
    #          $hp (IN): host port prefix
    #          @result (IN): message from server
    my $rc = shift;
    my $hp = shift;
    my $result = shift;
    log( "$hp returned ", $rc>>8, '/', ($rc & 127) );
    foreach ( @{$result} ) {
	last if ( /^s+at\sorg/ );
	log( $hp, ' ', $_ );
	last if ( /(?:ERROR|WARN)/ );
    }
}

sub delegate_create($$) {
    # purpose: create a new delegate
    # paramtr: $uri (IN): contact of WSRF
    #          $ttl (IN): seconds to live for delegate, or undef for default
    # globals: $tempfn (IN): template for the temporary filename
    # returns: contents of EPR file, which is some XML stuff
    #          returns undef in case of error.
    my $uri = URI->new( shift() );
    my $ttl = shift;
    my $hp = canonical($uri);
    my $host = $uri->host;
    my $port = $uri->port;

    my ($fh,$fn) = tempfile( $tempfn, DIR => File::Spec->tmpdir,
			     SUFFIX => '.epr', UNLINK => 0 );
    close $fh;
    my @args = ( $gcd, '-h', $host, '-p', $port );
    push( @args, '-l', $ttl ) if ( defined $ttl && $ttl > 0 );
    push( @args, $fn );
    log( "starting @args" );
    my $start = time();
    my @result = pipe_out_cmd( @args );
    my $diff = time() - $start;
    my $rc = $?;

    my $result = [];
    if ( $rc == 0 ) {
	# all is well
	local(*IN);
	local($/) = undef;
	if ( open( IN, "<$fn" ) ) {
	    $result->[0] = time() + ( $ttl || 43200 );
	    $_ = <IN>;
	    s/>[[:space:]]+</></g;
	    $result->[1] = $_;
	    close IN;
	    log( "$hp OK", sprintf( ", %.3f s duration", $diff ) );
	} else {
	    log( "$hp has no EPR file" );
	}
    } else {
	# unsuccessful
	show_error( $rc, $hp, @result );
	undef $result;
    }

    unlink $fn;
    $result;
}

sub delegate_update($$$) {
    # purpose: update existing delegate
    # paramtr: $uri (IN): contact of WSRF
    #          $ttl (IN): seconds to live for delegate, or undef for default
    #          $epr (IN): old EPR
    # globals: $tempfn (IN): template for the temporary filename
    # returns: contents of EPR file, which is some XML stuff
    #          returns undef in case of error.
    my $uri = URI->new( shift() );
    my $ttl = shift;
    my $epr = shift;
    my $hp = canonical($uri);
    my $host = $uri->host;
    my $port = $uri->port;

    my ($fh,$fn) = tempfile( $tempfn, DIR => File::Spec->tmpdir,
			     SUFFIX => '.epr', UNLINK => 0 );
    print $fh "$epr";
    close $fh;

    my @args = ( $gcr, '-e', $fn );
    push( @args, '-l', $ttl ) if ( defined $ttl && $ttl > 0 );
    log( "starting @args" );
    my $start = time();
    my @result = pipe_out_cmd( @args );
    my $diff = time() - $start;
    my $rc = $?;

    my $result = [];
    if ( $rc == 0 && $result[$#result] =~ /refresh done/i ) {
	# all is well
	$result->[0] = time() + ( $ttl || 43200 );
	log( "$hp OK", sprintf( ", %.3f s duration", $diff ) );
	$result->[1] = <IN>;
    } else {
	# unsuccessful
	show_error( $rc, $hp, @result );
	undef $result;
    }

    unlink $fn;
    $result;
}
    
sub delegate_destroy($$) {
    # purpose: destroys an existing delegate
    # paramtr: $hp (IN): host and port identifier
    #          $epr (IN): the delegation EPR
    # globals: $tempfn (IN): template for the temporary filename(s)
    # returns: 1 if ok, undef in case of error
    my $hp = shift;
    my $epr = shift;

    my ($fh,$fn) = tempfile( $tempfn, DIR => File::Spec->tmpdir,
			     SUFFIX => '.epr', UNLINK => 0 );
    print $fh "$epr";
    close $fh;

    my @args = ( $wsd, '-e', $fn );
    log( "starting @args" );
    my $start = time();
    my @result = pipe_out_cmd( @args );
    my $diff = time() - $start;
    my $rc = $?;

    my $result;
    if ( $rc == 0 && $result[$#result] =~ /operation was successful/i ) {
	# all is well
	log( "$hp OK", sprintf( ", %.3f s duration", $diff ) );
	$result = 1;
    } else {
	# unsuccessful
	show_error( $rc, $hp, @result );
	undef $result;
    }

    unlink $fn;
    $result;
}

sub delegation_destroy_all() {
    # purpose: destroy all known delegations
    # globals: %main::cache (IO): contains all delegations
    foreach my $hp ( keys %main::cache ) {
	log( "destroying $hp" );
	delegate_destroy( $hp, $main::cache{$hp} );
	delete $main::cache{$hp};
    }
}

sub check_cache($$$) {
    # purpose: check cache for request
    # paramtr: $cid (IN): client identification prefix
    #          $uri (IN): where to delegate to if necessary
    #          $ttl (IN): seconds to live for delegate, or undef for default
    # returns: vector: [0]: ttl 
    #                  [1]: EPR xml garble
    #          scalar: EPR xml garble
    my $cid = shift;
    my $uri = shift;
    my $ttl = shift;
    my $now = time();

    # logid
    my $hp = canonical($uri);
    if ( exists $main::cache{$hp} ) {
	# exists, let's check expiration
	my $when = $now;
	$when += $ttl if defined $ttl;
	log( "$cid $hp exists in cache" );

	if ( ! defined $main::cache{$hp} || @{$main::cache{$hp}} == 0 ) {
	    # last time failed, try to delegate again
	    log( "$cid $hp EPR empty, redelegating" );
	    my $result = delegate_create($uri,$ttl);
	    $main::cache{$hp} = $result if defined $result;
	} elsif ( $main::cache{$hp}->[0] < $when ) {
	    # expired, need to refresh
	    log( "$cid $hp TTL expired, refreshing" );

	    my $epr = $main::cache{$hp}->[1];
	    my $result = delegate_update($uri,$ttl,$epr);
	    $main::cache{$hp} = $result if defined $result;
	} else {
	    # all is well, return cached entry 
	    log( "$cid $hp in cache and valid" );
	}
    } else {
	# does not exist, create delegate
	log( "$cid $hp does not exist in cache" );
	my $result = delegate_create($uri,$ttl);
	$main::cache{$hp} = $result if defined $result;
    }

    # show what we will return
    if ( exists $main::cache{$hp} && defined $main::cache{$hp} ) {
	my %x = parse_epr( $main::cache{$hp}->[1] );
	log( "$cid := ", $x{Address} . '?' . $x{DelegationKey} );

	return wantarray ? @{$main::cache{$hp}} : $main::cache{$hp}->[1];
    } else {
	return wantarray ? () : undef;
    }
}	

sub dump_cache (;$) {
    # purpose: dump cache contents for fun
    # paramtr: $uri (opt. IN): which specific host:port to check
    # returns: cache dump as one string.
    my $uri = shift;
    my $result = '';
    undef $uri unless length($uri) && $uri ne '*';

    my $uuid = 'undef';
    if ( defined $uri ) {
	# list one uri
	my $hp = canonical($uri);
	my ($host,$port) = split /:/, $hp;
	my $ttl = $main::cache{$hp}->[0];
	$uuid = $1 if ( defined $main::cache{$hp}->[1] &&
			$main::cache{$hp}->[1] =~ m/>\s*$uuid_re\s*</o );
	$result = sprintf( "%15s:%-5u -> %11d %s\r\n", 
			   $host, $port, $ttl, $uuid );	
    } else {
	# wildcard list all
	foreach my $hp ( keys %main::cache ) {
	    my ($host,$port) = split /:/, $hp;
	    my $ttl = $main::cache{$hp}->[0];
	    $uuid = $1 if ( defined $main::cache{$hp}->[1] &&
			    $main::cache{$hp}->[1] =~ m/>\s*$uuid_re\s*</o );
	    $result .= sprintf( "%15s:%-5u -> %11d %s\r\n", 
				$host, $port, $ttl, $uuid );
	}
    }

    length($result) ? $result : "# no entries\r\n";
}

sub daemonize ($) {
    # purpose: Turn process into a daemon
    # paramtr: $fn (IN): name of file to connect stdout to
    # returns: -
    # warning: forks a couple of times
    my $fn = shift || croak "ERROR: Need a filename";

    # go to a safe place that is not susceptible to sudden umounts
    # FIXME: This may break some things
    chdir($workdir) || die "chdir $workdir: $!\n";

    # open logfile as stdout
    open( STDOUT, ">$fn" ) || die "open $fn: $!\n";
    chmod 0600, $fn || die "chmod $fn: $!\n";

    # fork and go 
    my $pid = fork();
    fatal( "fork" ) if ( $pid == -1 );
    exit(0) if ( $pid > 0 );	#  parent exits

    # daemon child -- fork again for System-V
    $pid = fork();
    fatal( "fork" ) if ( $pid == -1 );
    exit(0) if ( $pid > 0 );	# parent exits

    # setsid
    fatal( "setsid" ) if ( setsid() < 0 );
}

sub keep_foreground ($) {
    # purpose: Turn into almost deamon, but keep in foreground for Condor
    # paramtr: $fn (IN): name of file to connect stdout to
    # returns: -
    my $fn = shift || croak "ERROR: Need a filename";

    # go to a safe place that is not susceptible to sudden umounts
    # FIXME: This may break some things
    chdir($workdir) || die "chdir $workdir: $!\n";

    # open logfile as stdout -- dunno, if this shouldnt be rather
    # a "output = $fn" line in the submit file. 
    open( STDOUT, ">>$fn" ) || die "open $fn: $!\n";
    chmod 0600, $fn || die "chmod $fn: $!\n";

    # we cannot set sid, but we can become process group leader
    setpgid( 0, 0 ) || die "setpgid: $!\n";
}

#
# --- main ---------------------------------------------------
#

# check remainder on globus certificate
my $timeleft = get_user_time();
die "ERROR: No user certificate available\n" if $timeleft == -1;
die "ERROR: Too little time left on user certificate\n" if $timeleft < $margin;
my $timelast = time();

# turn into daemon process
umask 0002;
if ( $nodaemon == 0 ) {
    daemonize($logfile);
} elsif ( $nodaemon == 2 ) {
    keep_foreground($logfile);
}

# dup2( STDOUT, STDERR )
open( STDIN, '</dev/null' );
open( STDERR, ">&STDOUT" ); # dup2 STDERR onto STDOUT
select( STDERR ); $|=1; # autoflush
select( STDOUT ); $|=1; # autoflush

# say hi
log( 'starting [', $main::revision, '], using pid ', $$ );

# create server socket
my $sock;
if ( lc($family) eq 'inet' ) {
    $sock = create_socket_in( $socket, inet_aton('127.0.0.1') );
} elsif ( lc($family) eq 'unix' || lc($family) eq 'local' ) {
    $sock = create_socket_un( $socket );
} else {
    die "ERROR: Illegal protocol family $family\n";
}
log( 'listening on ', show_sockaddr(getsockname($sock)) );
END { 
    finish_socket($sock); 
    delegation_destroy_all(); 
}

# ignore dying shells
$SIG{HUP} = 'IGNORE';

# die nicely when asked to (Ctrl+C, system shutdown)
$SIG{INT} = $SIG{TERM} = $SIG{ALRM} = sub {
    log( 'graceful exit on signal ', $_[0] );
    finish_socket($sock);
    exit(1);
};

# kill self 2 hours before the user certificate expires
alarm($timeleft-$margin);

# permit dynamic changes of debug level
$SIG{USR1} = sub { ++$main::DEBUG };
$SIG{USR2} = sub { $main::DEBUG-- };

for ( $main::child = 0; 
      accept(CLI,$sock) || $main::child;
      $main::child=0, close(CLI) ) {
    next if $main::child;	# SIGCHLD interrupt

    # collect client stats
    my $client = '[' . show_sockaddr(getpeername(CLI)) . ']';
    log( 'connection from ', $client );

    # unbuffer
    select CLI; $|=1; select STDOUT;

    # NOTE: This is an iterative (non-concurrent) server on purpose!
    # NOTE: This is a one-shot server on purpose due to iterative blocks

    # check user proxy
    my $now = time();
    if ( $timelast + 600 < $now ) {
	# check again
	$timeleft = get_user_time();
	fatal( 'No user certificate available' )
	    if $timeleft == -1;
	fatal( 'Too little time left on user certificate' )
	    if $timeleft < $margin;
	log( "$client $timeleft s remaining on user proxy" );
	$timelast = $now;

	# adjust suicide, if the certificate was extended
	alarm($timeleft-$margin);
    }

    # what does the client want?
    if ( defined( $_ = <CLI> ) ) {
	last if length($_) == 0; # EOF
	my ($method,$uri,$ttl) = split;
	undef $ttl if length($ttl) == 0;
	if ( lc($method) eq 'get' ) {
	    log( $client, ' GET ', $uri );
	    my $epr = check_cache( $client, $uri, $ttl );
	    if ( defined $epr ) {
		printf CLI "200 OK, length=%u\r\n", length($epr)+2;
		print  CLI "$epr\r\n";
	    } else {
		printf CLI "404 Not Found, length=%u\r\n", length($epr)+2;
		print  CLI "$epr\r\n";
	    }
	} elsif ( lc($method) eq 'status' ) {
	    log( $client, ' STATUS ', $uri );
	    my $status = dump_cache($uri);
	    printf CLI "200 OK, length=%u\r\n", length($status);
	    print  CLI $status;
	} elsif ( lc($method) eq 'ping' ) {
	    log( $client, ' PING' );
	    syswrite( CLI, "200 OK\r\n" );
	} elsif ( lc($method) eq 'delete' ) {
	    log( $client, ' DELETE ', $uri );
	    my $hp = canonical($uri);
	    if ( exists $main::cache{$hp} ) {
		if ( delegation_destroy( $hp, $main::cache{$hp} ) ) {
		    print CLI "200 OK\r\n";
		    delete $main::cache{$hp};
		} else {
		    print CLI "500 Internal Server Error\r\n";
		}
	    } else {
		print CLI "404 Not Found\r\n";
	    }
#	} elsif ( lc($method) eq 'bye' || lc($method) eq 'exit' ) {
#	    log( $client, ' EXIT request' );
#	    print CLI "200 OK\r\n";
#	    last;
	} else {
	    log( $client, ' ILLEGAL method' );
	    syswrite( CLI, "501 Not implemented\r\n" ); 
	}
    } else {
	log( $client, ' EOF' ) if $main::DEBUG;
    }
}

# done
exit 0;
