#! /usr/local/bin/perl
# access.pl
########################################################################

########################################################################
# ACCESS CONTROL HOOK FOR SUBVERSION
#
# Programmed by David Weintraub
# Date: 6-June-2005
# Revision: $Id$
# Purpose:
#    To control access to files and properties. This program
#    parses a control file that contains the various permission
#    definitions. These can define a "Group" to be used for file
#    permissioning, a property that must be set for a particular
#    file, or a file permission and who is allowed to edit or not
#    edit that file.
#
#    The group consists of a group name and a list of valid
#    users. The group definition can contain other groups that
#    have already been defined. This is to prevent infinite
#    recursive group definitions.
#
#    The property definition consists of a file pattern to match,
#    and if the file being committed matches that file pattern,
#    then it checks to see if the property specified is set, and
#    that the value of that property matches the regex of the
#    specified value.
#
#    The file definition is a regex pattern for matching a file,
#    the type of permission (r = read only, w = write, a = add only),
#    and the names of the users with that type of permission. A
#    "read only" permission means that the specified user cannot
#    commit any changes to the files that match that regex
#    pattern. An "add only" permission means a user may add a
#    file, but not modify a file that matches the permission
#    (useful for tags), and "write" gives users full access to
#    the file.
#
#    Permissions are heirarchical in nature. The lowest is "r"
#    and the highest is "w" with "a" in the middle. A user is
#    granted the highest permission that matches the particular
#    file. This way, you can set "r" permission for everyone on a
#    particular file, then specify the individuals with full
#    permission. A special group "@ALL" means all users, and the
#    string "<USER>" will be replaced by the user's id in the
#    file pattern. This means you can do such things as:
#
#    foo/.*:r: @ALL
#    foo/.*:w: @mygroup
#
#    This will give read only permission for all users except for
#    the users listed in @mygroup. You can also do this:
#
#    /tags/.*:r: @ALL
#    /tags/<USER>/.*:a: @ALL
#    /tags/.*:w: @admin
#
#    This will prevent any user from writing to the /tag
#    directory. However, each user may add files to their own
#    subdirectory under /tags, but not edit them. Also, the
#    members of @admin are allowed full access in the /tags
#    directory. This will allow users to create tags under their
#    tags subdirectory, but not change those tags.
#
#    This program will parse the entire control file, then use
#    svnlook to examine all changes in the transaction. This way,
#    you only need to parse your control file once.
#
########################################################################

########################################################################
# PERL MODULES
#
use Getopt::Long;
#
########################################################################

########################################################################
# CONSTANTS
#
*DEFAULT_CONTROL_FILE = \"./control-file";
   our $DEFAULT_CONTROL_FILE;
*DEFAULT_DEBUG_LEVEL = \0;
   our $DEFAULT_DEBUG_LEVEL;
#*SVNLOOK = \"/usr/lib/subversion/bin/svnlook";
*SVNLOOK = \"/usr/local/bin/svnlook";
   our $SVNLOOK;
*PATH = \"/bin:/usr/bin";
   our $PATH;
#
########################################################################

########################################################################
# USAGE
#
our $USAGE = <<EOF;
usage:
    access.pl [-file <ctrlFile>] (-r<revision>|-t<transaction>) \\
        [-debug <debugLevel>] <repository>
    where:
	<ctrlFile>: Control File used for determining permissions
	    defaults to $DEFAULT_CONTROL_FILE.
	<revision>: Revision Number of archive (for testing)
	<transaction>: Transaction Number of Commit
	<debugLevel>: The debug level to implement>. Default
	    is $DEFAULT_DEBUG_LEVEL (zero means no debugging messages)
	<repository>: Full Path to Repository
EOF
#
########################################################################

########################################################################
# PRAGMAS
#
use strict;
use warnings;
#
########################################################################

########################################################################
# OTHER VARIABLES
#
my %groupHash;	#Hash of Lists containing group definitions
my @propList;	#Array of Hash containing property definitions
my @fileList;	#Array of Hash containing File Perm definitions
my $lineNumber = 0;
my $author;	#Name of user who made the changes
my @errorList = ();	#List of parsing error from Control File
#
########################################################################

########################################################################
#  GET COMMAND LINE OPTIONS
#
my $transactionNum;
my $revisionNum;
my $controlFile;
my $option;
my $repository;
my $debugLevel;

GetOptions(
    "t=s" => \$transactionNum,
    "r=i" => \$revisionNum,
    "file=s" => \$controlFile,
    "debug=i" => \$debugLevel
);

if ($revisionNum and $transactionNum) {
    die qq(You cannot specify both a revision and transaction number\n) .
	qq($USAGE\n);
}

unless ($controlFile) {
    $controlFile = $DEFAULT_CONTROL_FILE;
}

unless ($repository = $ARGV[0]) {
    die qq(You must specify a repository\n$USAGE\n);
}

if ($revisionNum) {
    $option = "-r $revisionNum";
} elsif ($transactionNum) {
    $option = "-t $transactionNum";
} else {
    die qq(You must specify either the "-t" or "-r" option\n$USAGE\n);
}

unless ($debugLevel) {
    $debugLevel = $DEFAULT_DEBUG_LEVEL;
}

########################################################################
# SUBROUTINE DEBUG
#
sub debug {
    if (($debugLevel > 0) && ($_[1] <= $debugLevel)) {
	print "    " x ($_[1] - 1) if ($_[1] >= 1);
	print "$_[0]\n";
    }
}
#
########################################################################

########################################################################
# SUBROUTINE ADD GROUP
#
# Purpose: To add a list of names to the groupHash (Which is a hash of lists)
#
sub addGroup {
    unless (/[^=]+\s*=\s*[^=]+/) {	#Check for Syntax Errors
	push (@errorList,
	    "Line $lineNumber: Error in parsing group:\n\t$_");
	return 1;
    }
    (my $group, my $members) = split (/\s*=\s*/);
    $group =~ s/\s//g;		#Remove Blanks
    $group =~ s/^@//;		#Remove "@" if on group
    $group = lc($group);	#Lowercase (Case is insignificant)
    debug("Group Defined = $group", 3);
    foreach my $member (split(/\s*,\s*/, $members)) {
	$member =~ s/\s//g;
	$member = lc($member);	#Case is insignificant
	if($member =~ /^@/) {	#This is a group!
	    $member =~ s/^@//;	#Name of Group
	    if (defined($groupHash{$member})) {
		push(@{$groupHash{"$group"}}, @{$groupHash{"$member"}});
	    } else {
		push(@errorList,
		    qq(Line #$lineNumber: Group "$member" undefined));
	    }
	} else {
	    push(@{$groupHash{"$group"}}, "$member");
	}
    }
    return 0;
}
#
########################################################################

########################################################################
# SUBROUTINE ADD PROPERTY
#
sub addProp {
    unless (/(\s*[^:]+)\s*:\s*([^=]+)\s*=\s*(.*)/) {
	push(@errorList,
	    "Line $lineNumber: Error in parsing property:\n\t$_");
	return 1;
	}
	my $subscript = $#propList + 1;	#Next free entry in @propList
	my $filePattern = $1;
	my $property = $2;
	my $propValue = $3;
	$filePattern =~ s/\s*(\S*)\s*$/$1/;
	$property =~ s/\s//g;		#Remove Blanks
	$propValue =~ s/^\s*"(.*)"\s*$/$1/;
	$propList[$subscript]->{"pattern"} = $filePattern;
	$propList[$subscript]->{"property"} = $property;
	$propList[$subscript]->{"value"} = $propValue;

    return 0;
}
#
########################################################################

########################################################################
# SUBROUTINE ADD FILE
#
# Purpose: To add a new file permission "record" to a List of Files
#    The record consists of a
#       * File Regex ("pattern")
#       * Permission ("permission") of either "a", "w", or "r"
#       * A hash of users with that permission ("member")
#
sub addFile {
    (my $filePattern, my $permission, my $members) = split(":");

    my $subscript = $#fileList + 1; 	#Subscript of fileList Array
    $filePattern =~ s/<USER>/$author/g;
    $fileList[$subscript]->{"pattern"} = $filePattern;
#
#   ####Check File Permissions
#

    if ($permission =~ /^(a|w|r)$/i) {
	$fileList[$subscript]->{"permission"} = lc($permission);
	debug("Adding \$fileList[$subscript]->{permission}", 3);
	debug("File = $fileList[$subscript]->{pattern}", 3);
	debug("Permission = $fileList[$subscript]->{permission}", 3);
    } else {
	push(@errorList,
	    qq(Line #$lineNumber: Bad File Permission: "$permission"));
	return 1;
    }

#
#   ####Parse Group Permissions
#

    my @memberList = ();
    foreach my $member (split(/\s*,\s*/, $members)) {
	$member =~ s/\s//g;
	if ($member eq "\@ALL") { #Special Case: Line for All Users 
	    @memberList = ();
	    $memberList[0] = "\@ALL";
	    debug("Adding Member \"\@ALL\" to group", 3);
	    last;		#All are included. Nothing else to parse
	}
	$member = lc($member);	#Case is insignificant
	if($member =~ /^@/) {	#This is a group!
	    $member =~ s/^@//;	#Name of Group
	    if (defined($groupHash{$member})) {
		push(@memberList, @{$groupHash{"$member"}});
	    } else {
		push(@errorList,
		    qq(Line: $lineNumber Group "$member" underfined));
	    }
	} else {
	    push(@memberList, "$member");
	    debug("Adding member \"$member\" to group", 3);
	}
    }

#
#   ####Reformat member group into a hash

    foreach my $member (@memberList) {
	$fileList[$subscript]->{"member"}->{"$member"} = 1;
    }
    return 0;
}
#
########################################################################

########################################################################
# OPEN THE CONTROL FILE
#
open (CONTROL, "$controlFile") or
    die "Cannot open file \"$controlFile\" for reading\n";
select(STDERR);	#Only STDERR lines print out
#
########################################################################

########################################################################
# PARSE IN CONTROL FILE
#

debug ("Parsing Control File:", 1);

#
#   ####Need Author because you need to replace <USER> in patterns
#

chomp ($author = qx($SVNLOOK author $option $repository));
debug (qq(Author is $author), 2);

while (<CONTROL>)
{
    $lineNumber++;
    chomp;
    debug("Line $lineNumber: $_", 2);
    next if (/^(#|--\s|\/\/)/);	#Ignore comments
    next if (/^\s*$/);		#Ignore Blank Lines
    if (s/group[^:]*://i){	# This is a Group Definition
	debug("Call addGroup()", 2);
	addGroup();
    }
    elsif(s/prop[^:]*://i) {	#This is a Property Definition
	debug("Call addProp()", 2);
	addProp();
    }
    elsif(s/file[^:]*://i) {	#This is a File Definition
	debug("Call addFile()", 2);
	addFile();
    }
    else {			#This is an error!
	push (@errorList,
	   "Line $lineNumber: Bad syntax in $controlFile\n\t$_");
    }
}
debug("Finished Parsing Control File", 1);

#
#   ####If Errors in Control File, Stop Processing
#

if (@errorList) {
    print qq(Commit failed due to parsing errors in file "$controlFile"\n);
    for my $error (@errorList) {
	print "    $error\n";
    }
    print "Number of errors: " . scalar(@errorList) . "\n";
    exit 2;
}
#
########################################################################

########################################################################
# PRINT GROUPS
#
foreach my $groupName (sort keys (%groupHash)) {
    debug ("Group: $groupName", 2);
    foreach my $member (@{$groupHash{"$groupName"}}) {
	debug ("$member", 3);
    }
}
#
########################################################################

########################################################################
# PRINT PROPERTIES
#
foreach my $property (@propList) {
    debug ("Pattern: " . $property->{"pattern"}, 2);
    debug ("Property: " . $property->{"property"} . " = " .
	qq("$property->{value}"\n\n), 3);
}
#
########################################################################

########################################################################
# PRINT FILES
#
foreach my $file (@fileList) {
    debug ("Pattern: " . $file->{"pattern"}, 2);
    debug ("Permission: " . $file->{"permission"}, 3);
    foreach my $member (sort keys %{$file->{"member"}}) {
	debug ("Member: $member", 4);
    }
}
#
########################################################################

########################################################################
# GET INFORMATION ABOUT THE FILES CHANGED
#
debug(qq(\nFinding files that changed), 1);

my $cmd = "$SVNLOOK changed $option $repository";
open (CHANGED, "$cmd|")
    or die qq(Cannot execute the command "$cmd"\n");

my @changeList = ();
my @checkPropList = ();
my @addList = ();

while (<CHANGED>)
{
    chomp;
    (my $status, my $file) = split;
    debug(qq(File: "$file" has a status of "$status"), 2);

    if ($status =~ /^U/) {
	push (@changeList, $file);	#File Modified (Need "w" permission)
	debug (qq(Added "$file" to \@changeList), 3);
	push (@checkPropList, $file);	#Check Property
	debug (qq(Added "$file" to \@checkPropList), 3);
    }
    elsif ($status =~ /^A/) {
	push (@addList, $file);		#File Added (Need "w" or "a" perm)
	debug (qq(Added "$file" to \@addList), 3);
	push (@checkPropList, $file);	#Check Property
	debug (qq(Added "$file" to \@checkPropList), 3);
    }
    elsif ($status =~ /^D/) {
	push (@changeList, $file);	#File Modified (Need "w" permission)
	debug (qq(Added "$file" to \@changeList), 3);
    }
    elsif ($status =~ /^.U/)		#File Prop Modified!
    {
	push (@checkPropList, $file);
	debug (qq(Added "$file" to \@checkPropList), 3);
    }
    else
    {
	die qq(Can't interpret change: "$_"\n);
    }
}
#
########################################################################

########################################################################
# FOR EACH FILE, SEE IF YOU HAVE THE PERMISSION TO CHANGE THE FILE
#
# Flag Status:
#  -1: Not specified (Allowed)
#   1: Specified Yes (Allowed)
#   0: Specifed No (Not Allowed)
#
my @userRejectList = ();	#List of rejected files

#
#    ####Check for Modifications (User is either not specified or given "w")
#

debug("\n", 1);
debug(qq(Checking \@changeList), 1);
foreach my $file (@changeList) {
my $userWriteFlag = -1;		#User Write Permission Not Specified
    debug (qq(Checking File "$file"), 2);
    foreach my $fileEntry (@fileList) {
	debug (qq(Comparing "$file" to /$fileEntry->{pattern}/), 3);
	if ($file =~ /$fileEntry->{"pattern"}/) { #File matches pattern
	    debug (qq(File "$file" matches pattern /$fileEntry->{pattern}/), 4);
	    debug (qq(Seeing if $author is in \$fileEntry->{member}), 5);
	    if (($fileEntry->{"member"}->{"$author"}) or 
		($fileEntry->{"member"}->{"\@ALL"})) {
		debug (qq($author is mentioned in \$fileEntry), 6);
		if ($fileEntry->{"permission"} =~ /^w$/i) {
		    debug("$author has permission!", 6);
		    $userWriteFlag = 1;
		    last;		#No need to check farther
		}
		elsif ($userWriteFlag == -1) {	#If not already Set
		    debug("$author doesn't have permission!", 6);
		    $userWriteFlag = 0;	#User doesn't have permission (yet)
		}	#Checking whether user is "w", "a", or "r"
	    }	    #If Permission applies to user
	}	#If pattern matches
    }
    debug("Checking \$userWriteFlag (value is $userWriteFlag)", 2);
    if ($userWriteFlag == 0) {
	debug("$author has no permission to change $file", 2);
	push (@userRejectList, qq(No permission to change file "$file"));
    }
}

#
#   ####Check for Additions (User not specified or given "a" or "w")
#

debug(qq(Checking \@addList), 1);
foreach my $file (@addList) {
my $userWriteFlag = -1;		#User Write Permission Not Specified
    debug (qq(Checking File "$file"), 2);
    foreach my $fileEntry (@fileList) {
	debug (qq(Comparing "$file" to /$fileEntry->{pattern}/), 3);
	if ($file =~ /$fileEntry->{"pattern"}/) { #File matches pattern
	    debug (qq(File "$file" matches pattern /$fileEntry->{pattern}/), 4);
	    debug (qq(Seeing if $author is in \$fileEntry->{member}), 5);
	    if (($fileEntry->{"member"}->{"$author"}) or 
		($fileEntry->{"member"}->{"\@ALL"})) {
		debug (qq($author is mentioned in \$fileEntry), 6);
		if ($fileEntry->{"permission"} =~ /^[aw]$/i) {
		    debug("$author has permission!", 6);
		    $userWriteFlag = 1;
		    last;		#No need to check farther
		}
		elsif ($userWriteFlag == -1) {	#If not already Set
		    $userWriteFlag = 0;	#User doesn't have permission (yet)
		}	#Checking whether user is "w", "a", or "r"
	    }	    #If Permission applies to user
	}	#If pattern matches
    }	# For each entry in File Permission List
    if ($userWriteFlag == 0) {
	push (@userRejectList, qq(No permission to add file "$file"));
    }
}
#
########################################################################

########################################################################
# CHECK PROPERTIES
#
debug("\nChecking \@checkPropList", 1);
foreach my $file (@checkPropList) {
    debug(qq(Checking File "$file"), 2);
    foreach my $fileEntry(@propList) {
	debug (qq(Comparing "$file" to /$fileEntry->{pattern}/), 3);
	if ($file =~ /$fileEntry->{"pattern"}/) { #Check This Property
	    debug (qq(File "$file" matches pattern /$fileEntry->{pattern}/), 4);
	    debug (qq(Seeing if property "$fileEntry->{property}" is set), 5);
	    my $property = $fileEntry->{"property"};
	    my $cmd = "$SVNLOOK propget $option " .
		"$repository $fileEntry->{property} $file 2> /dev/null";
	    unless (my $propValue = qx($cmd)) {
		push(@userRejectList,
		    qq(Property "$property" needed for file "$file".\n) .
		    qq(        Must match regex /$fileEntry->{value}/.));
	    } else {		#Property Found: Is it a good value?
		if ($propValue !~ /$fileEntry->{"value"}/) {
		    push (@userRejectList, 
			qq(Property "$property" for file "$file invalid.\n) .
			qq(        Must match regex /$fileEntry->{value}/.));
		}
	    }
	}	#If @propList has this file for this property
    } #For each file entry found in @propList
}
#
########################################################################

########################################################################
# CHECK USER REJECT LIST
#
if(scalar @userRejectList) {
    print "ERROR: Commit failed for the following reasons:\n";
    foreach my $entry (@userRejectList) {
	print "    $entry\n";
    }
    exit 2;
} else {	#Commit is fine
    exit 0;
}
#
########################################################################