#!/usr/bin/perl -wT
#######
# Data
#
# the regexp for the list of characters that are unsafe
# to put inside a system() or ``
# it is built by saying everything but known safe characters
# anyone want to make bets on if this holds true for i18n'ed systems?
my $safe_set  = '-A-Za-z0-9\s\._\/:';
my $unsafe_re = "[^$safe_set]";
my $safe_re   = "[$safe_set]*";

#
# pppdir - the directory containing the ppp config files
#
my $pppdir = $ENV{"PPPDIR"};
die "Stop screwing with me and set PPPDIR to something reasonable\n" if defined $pppdir && $pppdir =~ /$unsafe_re/o;
$pppdir = "/etc/ppp" unless defined $pppdir;

#
# chap_secrets - the full path to the the CHAP
#	(Challenge/Handshake Authentication Protocol) secrets file
#
my $chap_secrets = "$pppdir/chap-secrets";
my $pap_secrets = "$pppdir/pap-secrets";

#
# tunnel_dir - the directory containing tunnel config files
#
my $tunnel_dir = "$pppdir/peers";

#
# clean up the path since this is run as root.
$ENV{PATH} = "/bin:/usr/bin:/usr/sbin";
delete $ENV{BASH_ENV};
delete $ENV{IFS};
delete $ENV{ENV};

#######
#first some support functions that are used everywhere
#

#QueryUser <prompt> <default>
#
# Ask the user <prompt> and return the answer, <default> if cr
#
sub QueryUser($$) {
	my ($prompt, $default) = @_;
	
	print "$prompt";
	print " [$default]" if defined $default;
	print ": ";
	my $answer = <STDIN>;
	chomp $answer;
	$answer = $default if $answer eq "" and defined $default;
	return $answer;
}

#ConfiguredTunnels
#
# Returns a list of configured tunnels
#
sub ConfiguredTunnels() {
	my @tunnels = ();
	if( -d "$tunnel_dir" ) {
		foreach my $f (`cd $tunnel_dir; ls`) {
			chomp $f;
			next if $f eq "__default";
			my $p = "$tunnel_dir/$f";
			if( $p !~ /^($safe_re)$/o ) {
				print "Unsafe characters in tunnel name $p\n";
				next;
			}
			$p = $1;
			push @tunnels, $f if -f $p and `grep '# PPTP' $p`;
		}
	}
	return @tunnels;
}

#bselect
#
# a rough equilivent of the bourne shell's select
sub bselect($@) {
	my $prompt = shift;
	my @choices = @_;
	for my $i (0..$#choices) {
		print $i+1 .".) $choices[$i]\n";
	}
	my $reply = QueryUser $prompt, undef;
	return $reply;
}

#SelectTunnel - interactive
#
# Prints $_[0] as a prompt and returns the choice.
#
sub SelectTunnel($) {
	my $tunnel = "";
	my @tunnels = ConfiguredTunnels;
	while($tunnel eq "") {
		$tunnel = bselect $_[0], @tunnels;
	}
	return $tunnels[$tunnel - 1] if $tunnel =~ /^\d+$/;
	return $tunnel if grep {/$tunnel/} @tunnels;
	return "";
}

#AddTunnel <name> <ip> <local> <remote>
#
# Adds a new tunnel with name <name>, server ip address <ip>,
# and using the CHAP secret determined by local name <local> and remote
# name <remote>.
sub AddTunnel($$$$) {
	my ($name, $ip, $local, $remote) = @_;

	if( -f "$tunnel_dir/$name") {
		print "ERROR!  Peer $name already exists!\n";
		return;
	}

	open(PEER, ">$tunnel_dir/$name") 
	or die "can't open $tunnel_dir/$name for writing: $!";

	print PEER 
"#
# PPTP Tunnel configuration for tunnel $name
# Server IP: $ip\n";

	print PEER
"#
debug

pty \"/usr/sbin/pptp $ip --nolaunchpppd\"
connect /bin/true
defaultroute

# 
# Tags for CHAP secret selection
#
name $local
remotename $remote

#
# Tunnel name for ip-up.local or ip-up.d scripts
#
ipparam $name

#
# Include the main PPTP configuration file
#
file $pppdir/options.pptp

";

	close(PEER) or die "can't close $tunnel_dir/$name: $!";
	print "Added tunnel $name\n";
}

#DelTunnel <name>
#
# Deletes the tunnel named <name>
#
sub DelTunnel($) {
	my $name = $_[0];
	return if(!defined $name || $name eq "");
	if( ! -f "$tunnel_dir/$name" ) {
		print "ERROR! Peer $name does not exist!\n";
		return;
	}
	# force $name to be untainted
	# ($name is clean because it passed the -f test above, and it's not
	# being sent to a shell.  But -T doesn't know that.)
	$name =~ /^(.*)$/o;
	$name =$1;
	unlink "$tunnel_dir/$name";
	print "Removed tunnel $name\n";
}

#AddCHAPorPAP - interactive
#
# Prompts for parameters and adds a CHAP or PAP secret
#
sub AddCHAPorPAP {
	my $secret_type = $_[0];

	print
	"Add a NEW $secret_type secret.

NOTE: Any backslashes (\\) must be doubled (\\\\).

Local Name:

This is the 'local' identifier for $secret_type authentication.
 
NOTE: If the server is a Windows NT machine, the local name
	  should be your Windows NT username including domain.
	  For example:

		  domain\\\\username
 
";
	my $local = QueryUser "Local Name", undef;

	print
	"
Remote Name:

This is the 'remote' identifier for $secret_type authentication.
In most cases, this can be left as the default. It must be
set if you have multiple $secret_type secrets with the same local name
and different passwords. Just press ENTER to keep the default.

";
	my $remote = QueryUser "Remote Name", "PPTP";

	print
	"
Password:

This is the password or $secret_type secret for the account specified. The
password will not be echoed.

";
	# Get the password without echoing
	`stty -echo`;
	my $pass = QueryUser "Password", undef;
	`stty echo`;

	my $secrets_file = "";
	
	if( $secret_type eq "CHAP")	{
		$secrets_file = $chap_secrets;
	} elsif( $secret_type eq "PAP")	{
		$secrets_file = $pap_secrets;
	} else { 
		die ( "wrong sercet type!");
	}

	open(SECRETS_FILE, ">>$secrets_file") or die ("couldn't open $secrets_file: $!");
	print "\nAdding secret $local $remote password *\n\n";
	print SECRETS_FILE "$local\t$remote\t$pass\t*\n";
	# print SECRETS_FILE "$remote\t$local\t$pass\n";
	close(SECRETS_FILE) or die ("couldn't close $secrets_file: $!");
	chmod 0600, $secrets_file;
} # /AddCHAPorPAP()

#AddPPTP - interactive
#
# Add a new PPTP tunnel configuration
#
sub AddPPTP() {
	my ($name, $ip, $local, $remote);
	print "\nAdd a NEW PPTP Tunnel.\n\n";

	while (1) {
		$name = QueryUser "Tunnel Name", undef;
		# per man perlsec, check for special characters
		if ($name =~ /^([-\@\w.]+)$/) {
			$name = $1;
			last;
		}
		print "Name contains special characters.\n";
		print "Please use only alphanumerics, '-', '_', '.', and '\@'.\n";
	}
	$ip = QueryUser "Server IP", undef;

	print
	"Local Name and Remote Name should match a configured CHAP or PAP secret.
Local Name is probably your NT domain\\username.
NOTE: Any backslashes (\\) must be doubled (\\\\).

";

	$local = QueryUser "Local Name", undef;
	$remote = QueryUser "Remote Name", "PPTP";

	print "Adding $name - $ip - $local - $remote\n";

	AddTunnel $name, $ip, $local, $remote;
}

#getCHAPorPAP
#
# This returns all the CHAP or PAP secrets with ***ed out the paswords
sub getCHAPorPAP {
	my $secret_type = $_[0];
	
	my $secrets_file = "";
	
	if( $secret_type eq "CHAP")	{
		$secrets_file = $chap_secrets;
	} elsif( $secret_type eq "PAP")	{
		$secrets_file = $pap_secrets;
	} else { 
		die ( "wrong sercet type!");
	}

	if(-f $secrets_file) {
		my @list= `cat $secrets_file`;
		foreach my $secret (@list) {
			$secret =~ s/(.*\s)\S+\s*$/$1*****\n/
			unless $secret =~ /^\s*#/;
		}
		return @list;
	} else {
		return undef;
	}
}

#ManageSecrets
#
# This manages secret files
sub ManageSecrets {
	my $secret_type=$_[0];
	
	while(1) {
		my $manage_task = bselect "?", "List $secret_type secrets", 
		                               "Add a New $secret_type secret", 
									   "Delete a $secret_type secret",
									   "Quit";
								   
		if( $manage_task eq "1") {
			print "Current $secret_type secrets:\n";
			my @list = getCHAPorPAP( $secret_type);

			if( @list ) {
				print @list;
			} else {
				print "	None.\n";
			}		
		} elsif( $manage_task eq "2") {
			AddCHAPorPAP( $secret_type);
		} elsif( $manage_task eq "3") {
			my @list; 
			my $secrets_file;
			if( $secret_type eq "CHAP") {
				$secrets_file = $chap_secrets;
			} elsif( $secret_type eq "PAP") {
				$secrets_file = $pap_secrets;
			} else {
				die "wrong secret_type!";
			}
			
			@list = getCHAPorPAP( $secret_type);
			if( @list) {
				print "Select one of the pair of lines that you want removed.\n";
				print "Both matching lines will be deleted.\n";
				my $choice = bselect "Remove which $secret_type secret?", @list, "None";
				$choice--;
				if($choice == @list) {
					print "Aborted Deleting a $secret_type secret\n";
					next;
				} else {
					`stty -echo`;
					my $passwd = QueryUser "Enter the password for this $secret_type secret", undef;
					`stty echo`;
					my @secrets = `cat $secrets_file`;
					open(SECRETS_FILE, ">$secrets_file") or die "Couldn't open $secrets_file for writing: $!";
					my ($local, $remote, undef) = split(/\s/, $list[$choice]);
					my $count = 0;
					foreach my $c (@secrets) {
						my ($c_local, $c_remote, $c_secret, undef) = split(/\s/, $c);
						if( $c_secret eq $passwd && (
							  ($c_local eq $local && $c_remote eq $remote) ||
							  ($c_local eq $remote && $c_remote eq $local)
						  )) 
						{
							$count++;
							 next;
						} else {
							print SECRETS_FILE $c;
						}
					}
  					close(SECRETS_FILE) or die "Couldn't close $secrets_file after writing: $!";
					print "\nDeleted $count entries.";
					print " Perhaps you mistyped the password?" if $count == 0;
					print "\n";
				}	
			}
		} elsif( $manage_task eq "4" || $manage_task eq "q") {
			last;
		} else {
			next;
		}
	}
}

#setup
#
# This is the part that does the old pptp-setup work.
sub setup() {

	while(1) {
		my $task = bselect "?", "Manage CHAP secrets", 
		                        "Manage PAP secrets", 
		                        "List PPTP Tunnels", 
								"Add a NEW PPTP Tunnel",
                        		"Delete a PPTP Tunnel", 
								"Quit";

		if($task eq "1") {
			ManageSecrets( "CHAP");
		} elsif($task eq "2") {
			ManageSecrets( "PAP");
		} elsif($task eq "3") {
			my @tunnels = ConfiguredTunnels;
			print "Current Tunnels:\n";
			if(scalar(@tunnels) != 0) {
				print join "\n", @tunnels;
				print "\n";
			} else {
				print "	None.\n";
			}
		} elsif($task eq "4") {
			AddPPTP;
		} elsif($task eq "5") {
			my $tunnel = SelectTunnel "Delete which tunnel?";
			DelTunnel $tunnel if $tunnel ne "";
		} elsif($task eq "6" || $task eq "q") {
			exit 0;
		}
	}
}

#
# main
#
setup;
