scripts/commit-access-control.pl

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