#!/usr/bin/env perl

# ====================================================================
# commit-access-control.pl: check if the user that submitted the
# transaction TXN-NAME has the appropriate rights to perform the
# commit in repository REPOS using the permissions listed in the
# configuration file CONF_FILE.
#
# $HeadURL: http://svn.collab.net/repos/svn/branches/1.6.x/tools/hook-scripts/commit-access-control.pl.in $
# $LastChangedDate: 2008-03-25 14:42:32 +0000 (Tue, 25 Mar 2008) $
# $LastChangedBy: arfrever $
# $LastChangedRevision: 30041 $
#
# Usage: commit-access-control.pl REPOS TXN-NAME CONF_FILE
#    
# ====================================================================
# Copyright (c) 2000-2004 CollabNet.  All rights reserved.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution.  The terms
# are also available at http://subversion.tigris.org/license-1.html.
# If newer versions of this license are posted there, you may use a
# newer version instead, at your option.
#
# This software consists of voluntary contributions made by many
# individuals.  For exact contribution history, see the revision
# history and logs, available at http://subversion.tigris.org/.
# ====================================================================

# Turn on warnings the best way depending on the Perl version.
BEGIN {
  if ( $] >= 5.006_000)
    { require warnings; import warnings; }                      
  else  
    { $^W = 1; }               
}           

use strict;
use Carp;
use Config::IniFiles 2.27;

######################################################################
# Configuration section.

# Svnlook path.
my $svnlook = "/usr/bin/svnlook";

# Since the path to svnlook depends upon the local installation
# preferences, check that the required program exists to insure that
# the administrator has set up the script properly.
{
  my $ok = 1;
  foreach my $program ($svnlook)
    {
      if (-e $program)
        {
          unless (-x $program)
            {
              warn "$0: required program `$program' is not executable, ",
                   "edit $0.\n";
              $ok = 0;
            }
        }
      else
        {
          warn "$0: required program `$program' does not exist, edit $0.\n";
          $ok = 0;
        }
    }
  exit 1 unless $ok;
}

######################################################################
# Initial setup/command-line handling.

&usage unless @ARGV == 3;

my $repos        = shift;
my $txn          = shift;
my $cfg_filename = shift;

unless (-e $repos)
  {
    &usage("$0: repository directory `$repos' does not exist.");
  }
unless (-d $repos)
  {
    &usage("$0: repository directory `$repos' is not a directory.");
  }
unless (-e $cfg_filename)
  {
    &usage("$0: configuration file `$cfg_filename' does not exist.");
  }
unless (-r $cfg_filename)
  {
    &usage("$0: configuration file `$cfg_filename' is not readable.");
  }

# Define two constant subroutines to stand for read-only or read-write
# access to the repository.
sub ACCESS_READ_ONLY  () { 'read-only' }
sub ACCESS_READ_WRITE () { 'read-write' }

######################################################################
# Load the configuration file and validate it.
my $cfg = Config::IniFiles->new(-file => $cfg_filename);
unless ($cfg)
  {
    die "$0: error in loading configuration file `$cfg_filename'",
         @Config::IniFiles::errors ? ":\n@Config::IniFiles::errors\n"
                                   : ".\n";
  }

# Go through each section of the configuration file, validate that
# each section has the required parameters and complain about unknown
# parameters.  Compile any regular expressions.
my @sections = $cfg->Sections;
{
  my $ok = 1;
  foreach my $section (@sections)
    {
      # First check for any unknown parameters.
      foreach my $param ($cfg->Parameters($section))
        {
          next if $param eq 'match';
          next if $param eq 'users';
          next if $param eq 'access';
          warn "$0: config file `$cfg_filename' section `$section' parameter ",
               "`$param' is being ignored.\n";
          $cfg->delval($section, $param);
        }

      my $access = $cfg->val($section, 'access');
      if (defined $access)
        {
          unless ($access eq ACCESS_READ_ONLY or $access eq ACCESS_READ_WRITE)
            {
              warn "$0: config file `$cfg_filename' section `$section' sets ",
                "`access' to illegal value `$access'.\n";
              $ok = 0;
            }
        }
      else
        {
          warn "$0: config file `$cfg_filename' section `$section' does ",
            "not set `access' parameter.\n";
          $ok = 0;
        }

      my $match_regex = $cfg->val($section, 'match');
      if (defined $match_regex)
        {
          # To help users that automatically write regular expressions
          # that match the beginning of absolute paths using ^/,
          # remove the / character because subversion paths, while
          # they start at the root level, do not begin with a /.
          $match_regex =~ s#^\^/#^#;

          my $match_re;
          eval { $match_re = qr/$match_regex/ };
          if ($@)
            {
              warn "$0: config file `$cfg_filename' section `$section' ",
                   "`match' regex `$match_regex' does not compile:\n$@\n";
              $ok = 0;
            }
          else
            {
              $cfg->newval($section, 'match_re', $match_re);
            }
        }
      else
        {
          warn "$0: config file `$cfg_filename' section `$section' does ",
               "not set `match' parameter.\n";
          $ok = 0;
        }
    }
  exit 1 unless $ok;
}

######################################################################
# Harvest data using svnlook.

# Change into /tmp so that svnlook diff can create its .svnlook
# directory.
my $tmp_dir = '/tmp';
chdir($tmp_dir)
  or die "$0: cannot chdir `$tmp_dir': $!\n";

# Get the author from svnlook.
my @svnlooklines = &read_from_process($svnlook, 'author', $repos, '-t', $txn);
my $author = shift @svnlooklines;
unless (length $author)
  {
    die "$0: txn `$txn' has no author.\n";
  }

# Figure out what directories have changed using svnlook..
my @dirs_changed = &read_from_process($svnlook, 'dirs-changed', $repos,
                                      '-t', $txn);

# Lose the trailing slash in the directory names if one exists, except
# in the case of '/'.
my $rootchanged = 0;
for (my $i=0; $i<@dirs_changed; ++$i)
  {
    if ($dirs_changed[$i] eq '/')
      {
        $rootchanged = 1;
      }
    else
      {
        $dirs_changed[$i] =~ s#^(.+)[/\\]$#$1#;
      }
  }

# Figure out what files have changed using svnlook.
my @files_changed;
foreach my $line (&read_from_process($svnlook, 'changed', $repos, '-t', $txn))
  {
    # Split the line up into the modification code and path, ignoring
    # property modifications.
    if ($line =~ /^..  (.*)$/)
      {
        push(@files_changed, $1);
      }
  }

# Create the list of all modified paths.
my @changed = (@dirs_changed, @files_changed);

# There should always be at least one changed path.  If there are
# none, then there maybe something fishy going on, so just exit now
# indicating that the commit should not proceed.
unless (@changed)
  {
    die "$0: no changed paths found in txn `$txn'.\n";
  }

######################################################################
# Populate the permissions table.

# Set a hash keeping track of the access rights to each path.  Because
# this is an access control script, set the default permissions to
# read-only.
my %permissions;
foreach my $path (@changed)
  {
    $permissions{$path} = ACCESS_READ_ONLY;
  }

foreach my $section (@sections)
  {
    # Decide if this section should be used.  It should be used if
    # there are no users listed at all for this section, or if there
    # are users listed and the author is one of them.
    my $use_this_section;

    # If there are any users listed, then check if the author of this
    # commit is listed in the list.  If not, then delete the section,
    # because it won't apply.
    #
    # The configuration file can list users like this on multiple
    # lines:
    #   users = joe@mysite.com betty@mysite.com
    #   users = bob@yoursite.com

    # Because of the way Config::IniFiles works, check if there are
    # any users at all with the scalar return from val() and if there,
    # then get the array value to get all users.
    my $users = $cfg->val($section, 'users');
    if (defined $users and length $users)
      {
        my $match_user = 0;
        foreach my $entry ($cfg->val($section, 'users'))
          {
            unless ($match_user)
              {
                foreach my $user (split(' ', $entry))
                  {
                    if ($author eq $user)
                      {
                        $match_user = 1;
                        last;
                      }
                  }
              }
          }

        $use_this_section = $match_user;
      }
    else
      {
        $use_this_section = 1;
      }

    next unless $use_this_section;

    # Go through each modified path and match it to the regular
    # expression and set the access right if the regular expression
    # matches.
    my $access   = $cfg->val($section, 'access');
    my $match_re = $cfg->val($section, 'match_re');
    foreach my $path (@changed)
      {
        $permissions{$path} = $access if $path =~ $match_re;
      }
  }

# Go through all the modified paths and see if any permissions are
# read-only.  If so, then fail the commit.
my @failed_paths;
foreach my $path (@changed)
  {
    if ($permissions{$path} ne ACCESS_READ_WRITE)
      {
        push(@failed_paths, $path);
      }
  }

if (@failed_paths)
  {
    warn "$0: user `$author' does not have permission to commit to ",
         @failed_paths > 1 ? "these paths:\n  " : "this path:\n  ",
         join("\n  ", @failed_paths), "\n"; 
    exit 1;
  }
else
  {
    exit 0;
  }

sub usage
{
  warn "@_\n" if @_;
  die "usage: $0 REPOS TXN-NAME CONF_FILE\n";
}

sub safe_read_from_pipe
{
  unless (@_)
    {
      croak "$0: safe_read_from_pipe passed no arguments.\n";
    }
  print "Running @_\n";
  my $pid = open(SAFE_READ, '-|');
  unless (defined $pid)
    {
      die "$0: cannot fork: $!\n";
    }
  unless ($pid)
    {
      open(STDERR, ">&STDOUT")
        or die "$0: cannot dup STDOUT: $!\n";
      exec(@_)
        or die "$0: cannot exec `@_': $!\n";
    }
  my @output;
  while (<SAFE_READ>)
    {
      chomp;
      push(@output, $_);
    }
  close(SAFE_READ);
  my $result = $?;
  my $exit   = $result >> 8;
  my $signal = $result & 127;
  my $cd     = $result & 128 ? "with core dump" : "";
  if ($signal or $cd)
    {
      warn "$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n";
    }
  if (wantarray)
    {
      return ($result, @output);
    }
  else
    {
      return $result;
    }
}

sub read_from_process
  {
  unless (@_)
    {
      croak "$0: read_from_process passed no arguments.\n";
    }
  my ($status, @output) = &safe_read_from_pipe(@_);
  if ($status)
    {
      if (@output)
        {
          die "$0: `@_' failed with this output:\n", join("\n", @output), "\n";
        }
      else
        {
          die "$0: `@_' failed with no output.\n";
        }
    }
  else
    {
      return @output;
    }
}