tools/hook-scripts/commit-access-control.pl.in

   1 #!/usr/bin/env perl
   2
   3 # ====================================================================
   4 # commit-access-control.pl: check if the user that submitted the
   5 # transaction TXN-NAME has the appropriate rights to perform the
   6 # commit in repository REPOS using the permissions listed in the
   7 # configuration file CONF_FILE.
   8 #
   9 # $HeadURL$
  10 # $LastChangedDate$
  11 # $LastChangedBy$
  12 # $LastChangedRevision$
  13 #
  14 # Usage: commit-access-control.pl REPOS TXN-NAME CONF_FILE
  15 #
  16 # ====================================================================
  17 # Copyright (c) 2000-2004 CollabNet.  All rights reserved.
  18 #
  19 # This software is licensed as described in the file COPYING, which
  20 # you should have received as part of this distribution.  The terms
  21 # are also available at http://subversion.tigris.org/license-1.html.
  22 # If newer versions of this license are posted there, you may use a
  23 # newer version instead, at your option.
  24 #
  25 # This software consists of voluntary contributions made by many
  26 # individuals.  For exact contribution history, see the revision
  27 # history and logs, available at http://subversion.tigris.org/.
  28 # ====================================================================
  29
  30 # Turn on warnings the best way depending on the Perl version.
  31 BEGIN {
  32   if ( $] >= 5.006_000)
  33     { require warnings; import warnings; }
  34   else
  35     { $^W = 1; }
  36 }
  37
  38 use strict;
  39 use Carp;
  40 use Config::IniFiles 2.27;
  41
  42 ######################################################################
  43 # Configuration section.
  44
  45 # Svnlook path.
  46 my $svnlook = "@SVN_BINDIR@/svnlook";
  47
  48 # Since the path to svnlook depends upon the local installation
  49 # preferences, check that the required program exists to insure that
  50 # the administrator has set up the script properly.
  51 {
  52   my $ok = 1;
  53   foreach my $program ($svnlook)
  54     {
  55       if (-e $program)
  56         {
  57           unless (-x $program)
  58             {
  59               warn "$0: required program `$program' is not executable, ",
  60                    "edit $0.\n";
  61               $ok = 0;
  62             }
  63         }
  64       else
  65         {
  66           warn "$0: required program `$program' does not exist, edit $0.\n";
  67           $ok = 0;
  68         }
  69     }
  70   exit 1 unless $ok;
  71 }
  72
  73 ######################################################################
  74 # Initial setup/command-line handling.
  75
  76 &usage unless @ARGV == 3;
  77
  78 my $repos        = shift;
  79 my $txn          = shift;
  80 my $cfg_filename = shift;
  81
  82 unless (-e $repos)
  83   {
  84     &usage("$0: repository directory `$repos' does not exist.");
  85   }
  86 unless (-d $repos)
  87   {
  88     &usage("$0: repository directory `$repos' is not a directory.");
  89   }
  90 unless (-e $cfg_filename)
  91   {
  92     &usage("$0: configuration file `$cfg_filename' does not exist.");
  93   }
  94 unless (-r $cfg_filename)
  95   {
  96     &usage("$0: configuration file `$cfg_filename' is not readable.");
  97   }
  98
  99 # Define two constant subroutines to stand for read-only or read-write
 100 # access to the repository.
 101 sub ACCESS_READ_ONLY  () { 'read-only' }
 102 sub ACCESS_READ_WRITE () { 'read-write' }
 103
 104 ######################################################################
 105 # Load the configuration file and validate it.
 106 my $cfg = Config::IniFiles->new(-file => $cfg_filename);
 107 unless ($cfg)
 108   {
 109     die "$0: error in loading configuration file `$cfg_filename'",
 110          @Config::IniFiles::errors ? ":\n@Config::IniFiles::errors\n"
 111                                    : ".\n";
 112   }
 113
 114 # Go through each section of the configuration file, validate that
 115 # each section has the required parameters and complain about unknown
 116 # parameters.  Compile any regular expressions.
 117 my @sections = $cfg->Sections;
 118 {
 119   my $ok = 1;
 120   foreach my $section (@sections)
 121     {
 122       # First check for any unknown parameters.
 123       foreach my $param ($cfg->Parameters($section))
 124         {
 125           next if $param eq 'match';
 126           next if $param eq 'users';
 127           next if $param eq 'access';
 128           warn "$0: config file `$cfg_filename' section `$section' parameter ",
 129                "`$param' is being ignored.\n";
 130           $cfg->delval($section, $param);
 131         }
 132
 133       my $access = $cfg->val($section, 'access');
 134       if (defined $access)
 135         {
 136           unless ($access eq ACCESS_READ_ONLY or $access eq ACCESS_READ_WRITE)
 137             {
 138               warn "$0: config file `$cfg_filename' section `$section' sets ",
 139                 "`access' to illegal value `$access'.\n";
 140               $ok = 0;
 141             }
 142         }
 143       else
 144         {
 145           warn "$0: config file `$cfg_filename' section `$section' does ",
 146             "not set `access' parameter.\n";
 147           $ok = 0;
 148         }
 149
 150       my $match_regex = $cfg->val($section, 'match');
 151       if (defined $match_regex)
 152         {
 153           # To help users that automatically write regular expressions
 154           # that match the beginning of absolute paths using ^/,
 155           # remove the / character because subversion paths, while
 156           # they start at the root level, do not begin with a /.
 157           $match_regex =~ s#^\^/#^#;
 158
 159           my $match_re;
 160           eval { $match_re = qr/$match_regex/ };
 161           if ($@)
 162             {
 163               warn "$0: config file `$cfg_filename' section `$section' ",
 164                    "`match' regex `$match_regex' does not compile:\n$@\n";
 165               $ok = 0;
 166             }
 167           else
 168             {
 169               $cfg->newval($section, 'match_re', $match_re);
 170             }
 171         }
 172       else
 173         {
 174           warn "$0: config file `$cfg_filename' section `$section' does ",
 175                "not set `match' parameter.\n";
 176           $ok = 0;
 177         }
 178     }
 179   exit 1 unless $ok;
 180 }
 181
 182 ######################################################################
 183 # Harvest data using svnlook.
 184
 185 # Change into /tmp so that svnlook diff can create its .svnlook
 186 # directory.
 187 my $tmp_dir = '/tmp';
 188 chdir($tmp_dir)
 189   or die "$0: cannot chdir `$tmp_dir': $!\n";
 190
 191 # Get the author from svnlook.
 192 my @svnlooklines = &read_from_process($svnlook, 'author', $repos, '-t', $txn);
 193 my $author = shift @svnlooklines;
 194 unless (length $author)
 195   {
 196     die "$0: txn `$txn' has no author.\n";
 197   }
 198
 199 # Figure out what directories have changed using svnlook..
 200 my @dirs_changed = &read_from_process($svnlook, 'dirs-changed', $repos,
 201                                       '-t', $txn);
 202
 203 # Lose the trailing slash in the directory names if one exists, except
 204 # in the case of '/'.
 205 my $rootchanged = 0;
 206 for (my $i=0; $i<@dirs_changed; ++$i)
 207   {
 208     if ($dirs_changed[$i] eq '/')
 209       {
 210         $rootchanged = 1;
 211       }
 212     else
 213       {
 214         $dirs_changed[$i] =~ s#^(.+)[/\\]$#$1#;
 215       }
 216   }
 217
 218 # Figure out what files have changed using svnlook.
 219 my @files_changed;
 220 foreach my $line (&read_from_process($svnlook, 'changed', $repos, '-t', $txn))
 221   {
 222     # Split the line up into the modification code and path, ignoring
 223     # property modifications.
 224     if ($line =~ /^..  (.*)$/)
 225       {
 226         push(@files_changed, $1);
 227       }
 228   }
 229
 230 # Create the list of all modified paths.
 231 my @changed = (@dirs_changed, @files_changed);
 232
 233 # There should always be at least one changed path.  If there are
 234 # none, then there maybe something fishy going on, so just exit now
 235 # indicating that the commit should not proceed.
 236 unless (@changed)
 237   {
 238     die "$0: no changed paths found in txn `$txn'.\n";
 239   }
 240
 241 ######################################################################
 242 # Populate the permissions table.
 243
 244 # Set a hash keeping track of the access rights to each path.  Because
 245 # this is an access control script, set the default permissions to
 246 # read-only.
 247 my %permissions;
 248 foreach my $path (@changed)
 249   {
 250     $permissions{$path} = ACCESS_READ_ONLY;
 251   }
 252
 253 foreach my $section (@sections)
 254   {
 255     # Decide if this section should be used.  It should be used if
 256     # there are no users listed at all for this section, or if there
 257     # are users listed and the author is one of them.
 258     my $use_this_section;
 259
 260     # If there are any users listed, then check if the author of this
 261     # commit is listed in the list.  If not, then delete the section,
 262     # because it won't apply.
 263     #
 264     # The configuration file can list users like this on multiple
 265     # lines:
 266     #   users = joe@mysite.com betty@mysite.com
 267     #   users = bob@yoursite.com
 268
 269     # Because of the way Config::IniFiles works, check if there are
 270     # any users at all with the scalar return from val() and if there,
 271     # then get the array value to get all users.
 272     my $users = $cfg->val($section, 'users');
 273     if (defined $users and length $users)
 274       {
 275         my $match_user = 0;
 276         foreach my $entry ($cfg->val($section, 'users'))
 277           {
 278             unless ($match_user)
 279               {
 280                 foreach my $user (split(' ', $entry))
 281                   {
 282                     if ($author eq $user)
 283                       {
 284                         $match_user = 1;
 285                         last;
 286                       }
 287                   }
 288               }
 289           }
 290
 291         $use_this_section = $match_user;
 292       }
 293     else
 294       {
 295         $use_this_section = 1;
 296       }
 297
 298     next unless $use_this_section;
 299
 300     # Go through each modified path and match it to the regular
 301     # expression and set the access right if the regular expression
 302     # matches.
 303     my $access   = $cfg->val($section, 'access');
 304     my $match_re = $cfg->val($section, 'match_re');
 305     foreach my $path (@changed)
 306       {
 307         $permissions{$path} = $access if $path =~ $match_re;
 308       }
 309   }
 310
 311 # Go through all the modified paths and see if any permissions are
 312 # read-only.  If so, then fail the commit.
 313 my @failed_paths;
 314 foreach my $path (@changed)
 315   {
 316     if ($permissions{$path} ne ACCESS_READ_WRITE)
 317       {
 318         push(@failed_paths, $path);
 319       }
 320   }
 321
 322 if (@failed_paths)
 323   {
 324     warn "$0: user `$author' does not have permission to commit to ",
 325          @failed_paths > 1 ? "these paths:\n  " : "this path:\n  ",
 326          join("\n  ", @failed_paths), "\n";
 327     exit 1;
 328   }
 329 else
 330   {
 331     exit 0;
 332   }
 333
 334 sub usage
 335 {
 336   warn "@_\n" if @_;
 337   die "usage: $0 REPOS TXN-NAME CONF_FILE\n";
 338 }
 339
 340 sub safe_read_from_pipe
 341 {
 342   unless (@_)
 343     {
 344       croak "$0: safe_read_from_pipe passed no arguments.\n";
 345     }
 346   print "Running @_\n";
 347   my $pid = open(SAFE_READ, '-|');
 348   unless (defined $pid)
 349     {
 350       die "$0: cannot fork: $!\n";
 351     }
 352   unless ($pid)
 353     {
 354       open(STDERR, ">&STDOUT")
 355         or die "$0: cannot dup STDOUT: $!\n";
 356       exec(@_)
 357         or die "$0: cannot exec `@_': $!\n";
 358     }
 359   my @output;
 360   while (<SAFE_READ>)
 361     {
 362       chomp;
 363       push(@output, $_);
 364     }
 365   close(SAFE_READ);
 366   my $result = $?;
 367   my $exit   = $result >> 8;
 368   my $signal = $result & 127;
 369   my $cd     = $result & 128 ? "with core dump" : "";
 370   if ($signal or $cd)
 371     {
 372       warn "$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n";
 373     }
 374   if (wantarray)
 375     {
 376       return ($result, @output);
 377     }
 378   else
 379     {
 380       return $result;
 381     }
 382 }
 383
 384 sub read_from_process
 385   {
 386   unless (@_)
 387     {
 388       croak "$0: read_from_process passed no arguments.\n";
 389     }
 390   my ($status, @output) = &safe_read_from_pipe(@_);
 391   if ($status)
 392     {
 393       if (@output)
 394         {
 395           die "$0: `@_' failed with this output:\n", join("\n", @output), "\n";
 396         }
 397       else
 398         {
 399           die "$0: `@_' failed with no output.\n";
 400         }
 401     }
 402   else
 403     {
 404       return @output;
 405     }
 406 }