#!/usr/bin/perl -w

# 2005-04-07_17-46-38
#  * add -o sshc:verbose
# 2005-04-07_17-32-22
#  * handle -v
# 2005-04-07_12-12-25
#  * initial release

# Usage:

# Place this somewhere in your $PATH.  Then, whenever you need to call
# ssh, call this instead.
#
# When certain options are selected, the script skips the cache code,
# and instead calls ssh directly.  Currently, -MSV(including the -o
# variants(ControlMaster|ControlPath)) and any unregcognized option.
#
# Some options do not make sense for the backgrounded master; these
# include -fNsv.  Instead, those are filtered out, and passed only to
# the client.
#
# Any options left over after filtering are built into a string, which
# is then used as a key for the state data.
#
# This script requires use of a ssh patched to support -o PidFile.  See
# http://bugs.debian.org/303452.
#
# If you want to use this for scp, then use the -S option.
#
# If sshc-cleaner is syminked to this, and run every so often, it'll
# clean stale unused connections, and remove directories where the
# connection has been closed.  In this mode, a single argument is
# accepted: the number of seconds beyond which to consider a cached
# connection stale.  This defaults to 600 seconds.
#
# You also need to install lockfile-progs.

use strict;
use warnings;

use POSIX ":sys_wait_h";
use File::Temp qw( tempdir );

use Data::Dumper;

my $hostname = `hostname`;
chomp( $hostname );
my $ROOT = "$ENV{'HOME'}/.ssh/.pipes/$hostname";
my ( @server_opts, @client_opts, @rest, $host, $BASE );
my %options = (
	'sshc' => {
		'sshc:verbose' => 0,
	},
);

sub message($$) {
	my ( $level, $message ) = @_;
	print( STDERR join( '', map( { "sshc-debug($level): $_\n" } split( /\n/, $message ) ) ) ) if ( $options{ 'sshc' }->{ 'sshc:verbose' } ge $level );
}

sub lock_host() {
	my $file = "$ROOT/lock";
	system( 'mkdir', '-p', $ROOT );
	error( "Couldn't create lockfile for host" ) if ( system( 'lockfile-create', $file ) );
}

sub unlock_host() {
	system( 'lockfile-remove', "$ROOT/lock" );
}

sub lock_ssh() {
	my $file = "$BASE/lock";
	system( 'mkdir', '-p', $BASE );
	error( "Couldn't create lockfile for pipe check" ) if ( system( 'lockfile-create', $file ) );
}

sub unlock_ssh() {
	system( 'lockfile-remove', "$BASE/lock" );
}

sub error(@) {
	print( STDERR "@_\n" );
	unlock_ssh();
	exit( 1 );
}

sub no_wrap($;$) {
	my @args = ( @server_opts, @client_opts );
	my ( $label, $opt ) = @_;
	push( @args, $opt ) if ( $opt );
	push( @args, @ARGV );
	print( STDERR "no_wrap($label): @args\n" );
	exec( 'ssh', @args ) || error( "no_wrap: couldn't exec ssh" );
}

sub get_number($) {
	my ( $file ) = @_;
	if ( open( F, '<', $file ) ) {
		my $cur = <F>;
		close( F );
		return $cur;
	}
	return 0;
}

sub set_number($$) {
	my ( $file, $number ) = @_;
	open( F, '>', $file );
	print( F $number );
	close( F );
}

sub incr_count($$) {
	my ( $file, $change ) = @_;
	set_number( $file, get_number( $file ) + $change );
}

# must be called with the host locked
sub check_server() {
	my $pipe = "$BASE/control";
	return 1 if ( ! -S $pipe );
	my $cur = get_number( "$BASE/count" );
	return 0 if ( $cur != 0 );
	return 0;
}

sub run_client() {
	my $pipe = "$BASE/control";
	return if ( ! -S $pipe );
	my @args = ( '-S', $pipe, @client_opts, 'dummy', @rest );
	my $count_file = "$BASE/count";
	incr_count( $count_file, 1 );
	unlock_ssh();
	message( 1, "running client[@args]" );
	system( 'ssh', @args );
	lock_ssh();
	incr_count( $count_file, -1 );
	unlock_ssh();
	exit( 0 );
}

sub run_server() {
	my $pipe = "$BASE/control";
	my @args = ( '-fMNS', $pipe, '-o', "PidFile $BASE/pid", @server_opts, $host );
	debug( 1, 'running server[' . join( ' ', map( { "{$_}" } @args ) ) . ']' );
	my $pid = fork();
	die( "couldn't fork" ) if ( !defined( $pid ) );
	exec( 'ssh', @args ) && error( "run_server: couldn't run ssh" ) if ( !$pid );

	my $r;
	while ( ( $r = waitpid( $pid, WNOHANG ) ) != $pid ) {
		select( undef, undef, undef, .1 );
		return if ( -S $pipe );
	}
	error( "server didn't start($r:$?)" );
}
if ( $0 =~ m/\/sshc-cleaner$/ ) {
	my $stale_time = shift( @ARGV ) || 600;
	open( FIND, '-|', 'find', $ROOT, '-maxdepth', '2', '-mindepth', '2' ) || die( "open: find: $!" );
	my $start = time();
	my %hosts;
	while ( <FIND> ) {
		chomp;
		m/^\Q$ROOT\E\/([^\/]+)\/([^\/]*)$/;
		my ( $host, $dir ) = ( $1, $2 );
		$BASE = $_;
		lock_ssh();
		my $need_clean = '';
		if ( ! -S "$BASE/control" ) {
			$need_clean = 'master not running';
		} else {
			if ( get_number( "$BASE/count" ) == 0 ) {
				my $mod = ( stat( "$BASE/count" ) )[ 9 ];
				if ( $mod + $stale_time < $start ) {
					my $pid = get_number( "$BASE/pid" );
					kill( 2, $pid );
					$need_clean = 'staleness';
				}
			}
		}
		if ( $need_clean ) {
			open( ARGS, '<', "$BASE/args" );
			my $args = <ARGS> || '';
			close( ARGS );
			print( STDOUT "Cleaning host($host) args($args) due to: $need_clean\n" );
			system( 'rm', '-rf', $BASE );
			$hosts{ $host } = 1;
		} else {
			unlock_ssh();
		}
	}
	if ( %hosts ) {
		my @dirs = ( $ROOT, map( { "$ROOT/$_" } keys( %hosts ) ) );
		unlink( @dirs );
	}
	exit( 0 );
}
#$server{ 'values' }->{ 'escapechar' } = '~';
#$server{ 'values' }->{ 'addressfamily' } = 'any';
#$server{ 'flags' }->{ 'forwardagent' } = 'no';
# sf: server flag
# sm: server multi-value
# sv: server value
# cf: client flag
# cm: client multi-value
# cv: client value
# w: no_wrap
# undef: no_wrap
my %option_types = (
	'host'					=> undef,
	'addressfamily'				=> 'sv',
	'batchmode'				=> 'sf',
	'background'				=> 'sf',
	'bindaddress'				=> 'sv',
	'challengeresponseauthentication'	=> 'sf',
	'checkhostip'				=> 'sf',
	'cipher'				=> 'sv',
	'ciphers'				=> 'sv',
	'clearallforwardings'			=> 'cf',
	'compression'				=> 'sf',
	'compressionlevel'			=> 'sv',
	'connectionattempts'			=> 'sv',
	'connecttimeout'			=> 'sv',
	'controlmaster'				=> undef,
	'controlpath'				=> undef,
	'dynamicforward'			=> 'cf',
	'enablekeysign'				=> undef,
	'escapechar'				=> 'cv',
	'forwardagent'				=> 'sf',
	'forwardx11'				=> 'sf',
	'forwardx11trusted'			=> 'sf',
	'gatewayports'				=> 'sf',
	'globalknownhostsfile'			=> 'sv',
	'gssapiauthentication'			=> 'sf',
	'gssapidelegatecredentials'		=> 'sf',
	'hostbasedauthentication'		=> 'sf',
	'hostkeyalgorithms'			=> 'sv',
	'hostkeyalias'				=> undef,
	'hostname'				=> undef,
	'identityfile'				=> 'sm',
	'identitiesonly'			=> 'sf',
	'localforward'				=> 'cm',
	'loglevel'				=> 'cv',
	'macs'					=> 'sv',
	'nohostauthenticationforlocalhost'	=> 'sf',
	'numberofpasswordprompts'		=> 'sv',
	'passwordauthentication'		=> 'sf',
	'pidfile'				=> 'cv',
	'port'					=> 'sv',
	'preferredauthentications'		=> 'sv',
	'protocol'				=> 'sv',
	'proxycommand'				=> 'sv',
	'pubkeyauthentication'			=> 'sf',
	'remoteforward'				=> 'cm',
	'rhostsrsaauthentication'		=> 'sf',
	'rsaauthentication'			=> 'sf',
	'sendenv'				=> 'cm',
	'serveraliveinterval'			=> 'sv',
	'serveralivecountmax'			=> 'sv',
	'setuptimeout'				=> 'sv',
	'smartcarddevice'			=> 'sv',
	'strictHostkeychecking'			=> 'sf',
	'subsystem'				=> 'cf',
	'tcpkeepalive'				=> 'sf',
	'useprivilegedport'			=> 'sf',
	'user'					=> 'sv',
	'userknownhostsfile'			=> 'sv',
	'verifyhostkeydns'			=> 'sv',
	'verbose'				=> 'c+',
	'xauthlocation'				=> 'sv',

	'sshc:verbose'				=> 'h+',
);
sub set_named_option($\$;$) {
	my ( $name, $opt, $value ) = @_;
message( 3, "set_named_option: name[$name] opt[$$opt] value[" . ( $value ? $value : '' ) . ']' );
	my $lname = lc( $name );
	no_wrap( "unknown option($name)", $$opt ) if ( !exists( $option_types{ $lname } ) );
	my $type = $option_types{ $lname };
	no_wrap( "invalid option($name)", $$opt ) if ( !$type );
	my $hash_name;
	if ( $type =~ s/^s// ) {
		$hash_name = 'server';
	} elsif ( $type =~ s/^c// ) {
		$hash_name = 'client';
	} elsif ( $type =~ s/^h// ) {
		$hash_name = 'sshc';
	} else {
		die( "Internal error($type)" );
	}
	if ( !defined( $value ) && $type ne '+' ) {
		if ( $$opt ) {
			$value = $$opt;
			$$opt = '';
		} else {
			$value = shift( @ARGV );
		}
	}
	if ( $type eq 'm' ) {
		push( @{ $options{ $hash_name }->{ $lname } }, $value );
	} elsif ( $type eq 'f' ) {
		$options{ $hash_name }->{ $lname } = lc( $value );
	} elsif ( $type eq '+' ) {
		if ( $value ) {
			$options{ $hash_name }->{ $lname } = $value;
		} else {
			$options{ $hash_name }->{ $lname }++;
		}
	} else {
		$options{ $hash_name }->{ $lname } = $value;
	}
}
my %short_option_types = (
	'1'	=> 'protocol:1',
	'2'	=> 'protocol:2',
	'4'	=> 'addressfamily:inet',
	'6'	=> 'addressfamily:inet6',
	'A'	=> 'forwardagent:yes',
	'a'	=> 'forwardagent:no',
	'b'	=> 'bindaddress',
	'C'	=> 'compression:yes',
	'D'	=> 'dynamicforward',
	'e'	=> 'escapechar',
	'f'	=> 'background:yes',
	'g'	=> 'gatewayports:yes',
	'I'	=> 'smartcarddevice',
	'i'	=> 'identityfile',
	'k'	=> 'gssapidelegatecredentials:no',
	'L'	=> 'localforward',
	'l'	=> 'user',
	'M'	=> 'controlmaster:yes',
	'm'	=> 'macs',
	'N'	=> 'nocommand:yes',
	'n'	=> 'redirectstdin:yes',
	'p'	=> 'port',
	'R'	=> 'remoteforward',
	'S'	=> 'controlpath',
	's'	=> 'subsystem:yes',
	'T'	=> 'forcepseudotty:no',
	't'	=> 'forcepseudotty:yes',
	'V'	=> 'version',
	'v'	=> 'verbose',
	'X'	=> 'forwardx11:yes',
	'x'	=> 'forwardx11:no',
	'Y'	=> 'forwardx11trusted:yes'
);

my %inverse_short_options;

while ( my ( $char, $type ) = each( %short_option_types ) ) {
	$inverse_short_options{ $type } = $char;
}

sub set_short_option($\$) {
	my ( $char, $opt ) = @_;
message( 3, "set_short_option: char[$char] opt[$$opt]" );
	my $type = $short_option_types{ $char };
	unshift( @ARGV, $opt ), no_wrap( "invalid option($char)", '-' . $char ) if ( !$type );
	$type =~ m/^([^:]+)(?::(.*))?$/;
	my ( $name, $value ) = ( $1, $2 );
	set_named_option( $name, $$opt, $value );
}

sub build_args(%) {
	my %hash = @_;
	my @args;
	my $short_args;
	foreach my $key ( sort( keys( %hash ) ) ) {
		my $value = $hash{ $key };
		my $type = $option_types{ $key };
		if ( ref( $value ) eq 'ARRAY' ) {
			my $char = $inverse_short_options{ $key };
			if ( $char ) {
				push( @args, '-' . $char, $_ ) foreach ( @$value );
			} else {
				push( @args, '-o' . $key . ' ' . $_ ) foreach ( @$value );
			}
		} elsif ( ref( $value ) ) {
			die( "internal error($value)" );
		} else {
			my $multi = ( $type =~ m/\+$/ );
			my $char = $inverse_short_options{ $multi ? $key : $key . ':' . $value };
			if ( $char ) {
				if ( $multi ) {
					$short_args .= $char x $value;
				} else {
					$short_args .= $char;
				}
			} else {
				push( @args, '-o' . $key . ' ' . $value );
			}
		}
	}
	push( @args, '-' . $short_args ) if ( $short_args );
	return @args;
}

message( 4, join( ' ', map( { "{$_}" } @ARGV ) ) . "\n" );

while ( @ARGV ) {
	my $opt = shift( @ARGV );
	if ( $opt =~ m/^--/ ) {
		no_wrap( '--', $opt );
	} elsif ( $opt =~ s/^-// ) {
		while ( $opt =~ s/^(.)// ) {
			my $short_opt = $1;
			if ( $short_opt eq 'o' ) {
				$opt = shift( @ARGV ) if ( !$opt );
				no_wrap( "bad -o specification($opt)", "-o$opt" ) if ( $opt !~ s/^([^ =]+)(?:\s+|=)([^\s]+)$// );
				set_named_option( $1, $opt, $2 );
			} else {
				set_short_option( $short_opt, $opt );
			}
		}
	} else {
		push( @rest, $opt );
	}
}
message( 4, Dumper( \%options, \@rest ) );
$host = shift( @rest );
$options{ 'server' }->{ 'user' } = $1 if ( $host =~ s/(.*)\@// );
no_wrap( 'f' ) if ( $options{ 's' } && @rest != 1 );

@server_opts = build_args( %{ $options{ 'server' } } );
@client_opts = build_args( %{ $options{ 'client' } } );
message( 4,  Dumper( \@server_opts, \@client_opts ) );

my $name = join( ' ', map( { my $f = $_; local $_ = $f; s/%/%25/g; s/\\/%5C/g; s/"/%22/g; s/ /%20/g; s/\t/%09/g; s/\//%2F/g; $_ } @server_opts ) );
lock_host();
if ( -d "$ROOT/$host" ) {
	open( FIND, '-|', 'find', "$ROOT/$host", '-type', 'd', '-maxdepth', '1', '-mindepth', '1' ) || die( "open: find: $!" );
	while ( <FIND> ) {
		chomp;
		m/^\Q$ROOT\E\/([^\/]+)$/;
		if ( open( ARGS, '<', "$_/args" ) ) {
			$BASE = $_, last if ( $name eq <ARGS> );
		}
		close( ARGS );
	}
}
close( FIND );
system( 'mkdir', '-p', "$ROOT/$host" ), $BASE = tempdir( 'DIR' => "$ROOT/$host" ) if ( !$BASE );
unlock_host();
system( 'mkdir', '-p', $BASE );
lock_ssh();
check_server() || run_client();
open( ARGS, '>', "$BASE/args" );
print( ARGS $name );
close( ARGS );
run_server();
run_client();