Merge branch 'maint' of git://repo.or.cz/git-gui into maint
[git] / contrib / hooks / update-paranoid
1 #!/usr/bin/perl
2
3 use strict;
4 use File::Spec;
5
6 $ENV{PATH}     = '/opt/git/bin';
7 my $acl_git    = '/vcs/acls.git';
8 my $acl_branch = 'refs/heads/master';
9 my $debug      = 0;
10
11 =doc
12 Invoked as: update refname old-sha1 new-sha1
13
14 This script is run by git-receive-pack once for each ref that the
15 client is trying to modify.  If we exit with a non-zero exit value
16 then the update for that particular ref is denied, but updates for
17 other refs in the same run of receive-pack may still be allowed.
18
19 We are run after the objects have been uploaded, but before the
20 ref is actually modified.  We take advantage of that fact when we
21 look for "new" commits and tags (the new objects won't show up in
22 `rev-list --all`).
23
24 This script loads and parses the content of the config file
25 "users/$this_user.acl" from the $acl_branch commit of $acl_git ODB.
26 The acl file is a git-config style file, but uses a slightly more
27 restricted syntax as the Perl parser contained within this script
28 is not nearly as permissive as git-config.
29
30 Example:
31
32   [user]
33     committer = John Doe <john.doe@example.com>
34     committer = John R. Doe <john.doe@example.com>
35
36   [repository "acls"]
37     allow = heads/master
38     allow = CDUR for heads/jd/
39     allow = C    for ^tags/v\\d+$
40
41 For all new commit or tag objects the committer (or tagger) line
42 within the object must exactly match one of the user.committer
43 values listed in the acl file ("HEAD:users/$this_user.acl").
44
45 For a branch to be modified an allow line within the matching
46 repository section must be matched for both the refname and the
47 opcode.
48
49 Repository sections are matched on the basename of the repository
50 (after removing the .git suffix).
51
52 The opcode abbrevations are:
53
54   C: create new ref
55   D: delete existing ref
56   U: fast-forward existing ref (no commit loss)
57   R: rewind/rebase existing ref (commit loss)
58
59 if no opcodes are listed before the "for" keyword then "U" (for
60 fast-forward update only) is assumed as this is the most common
61 usage.
62
63 Refnames are matched by always assuming a prefix of "refs/".
64 This hook forbids pushing or deleting anything not under "refs/".
65
66 Refnames that start with ^ are Perl regular expressions, and the ^
67 is kept as part of the regexp.  \\ is needed to get just one \, so
68 \\d expands to \d in Perl.  The 3rd allow line above is an example.
69
70 Refnames that don't start with ^ but that end with / are prefix
71 matches (2nd allow line above); all other refnames are strict
72 equality matches (1st allow line).
73
74 Anything pushed to "heads/" (ok, really "refs/heads/") must be
75 a commit.  Tags are not permitted here.
76
77 Anything pushed to "tags/" (err, really "refs/tags/") must be an
78 annotated tag.  Commits, blobs, trees, etc. are not permitted here.
79 Annotated tag signatures aren't checked, nor are they required.
80
81 The special subrepository of 'info/new-commit-check' can
82 be created and used to allow users to push new commits and
83 tags from another local repository to this one, even if they
84 aren't the committer/tagger of those objects.  In a nut shell
85 the info/new-commit-check directory is a Git repository whose
86 objects/info/alternates file lists this repository and all other
87 possible sources, and whose refs subdirectory contains symlinks
88 to this repository's refs subdirectory, and to all other possible
89 sources refs subdirectories.  Yes, this means that you cannot
90 use packed-refs in those repositories as they won't be resolved
91 correctly.
92
93 =cut
94
95 my $git_dir = $ENV{GIT_DIR};
96 my $new_commit_check = "$git_dir/info/new-commit-check";
97 my $ref = $ARGV[0];
98 my $old = $ARGV[1];
99 my $new = $ARGV[2];
100 my $new_type;
101 my ($this_user) = getpwuid $<; # REAL_USER_ID
102 my $repository_name;
103 my %user_committer;
104 my @allow_rules;
105 my @path_rules;
106 my %diff_cache;
107
108 sub deny ($) {
109         print STDERR "-Deny-    $_[0]\n" if $debug;
110         print STDERR "\ndenied: $_[0]\n\n";
111         exit 1;
112 }
113
114 sub grant ($) {
115         print STDERR "-Grant-   $_[0]\n" if $debug;
116         exit 0;
117 }
118
119 sub info ($) {
120         print STDERR "-Info-    $_[0]\n" if $debug;
121 }
122
123 sub git_value (@) {
124         open(T,'-|','git',@_); local $_ = <T>; chop; close T; $_;
125 }
126
127 sub match_string ($$) {
128         my ($acl_n, $ref) = @_;
129            ($acl_n eq $ref)
130         || ($acl_n =~ m,/$, && substr($ref,0,length $acl_n) eq $acl_n)
131         || ($acl_n =~ m,^\^, && $ref =~ m:$acl_n:);
132 }
133
134 sub parse_config ($$$$) {
135         my $data = shift;
136         local $ENV{GIT_DIR} = shift;
137         my $br = shift;
138         my $fn = shift;
139         info "Loading $br:$fn";
140         open(I,'-|','git','cat-file','blob',"$br:$fn");
141         my $section = '';
142         while (<I>) {
143                 chomp;
144                 if (/^\s*$/ || /^\s*#/) {
145                 } elsif (/^\[([a-z]+)\]$/i) {
146                         $section = lc $1;
147                 } elsif (/^\[([a-z]+)\s+"(.*)"\]$/i) {
148                         $section = join('.',lc $1,$2);
149                 } elsif (/^\s*([a-z][a-z0-9]+)\s*=\s*(.*?)\s*$/i) {
150                         push @{$data->{join('.',$section,lc $1)}}, $2;
151                 } else {
152                         deny "bad config file line $. in $br:$fn";
153                 }
154         }
155         close I;
156 }
157
158 sub all_new_committers () {
159         local $ENV{GIT_DIR} = $git_dir;
160         $ENV{GIT_DIR} = $new_commit_check if -d $new_commit_check;
161
162         info "Getting committers of new commits.";
163         my %used;
164         open(T,'-|','git','rev-list','--pretty=raw',$new,'--not','--all');
165         while (<T>) {
166                 next unless s/^committer //;
167                 chop;
168                 s/>.*$/>/;
169                 info "Found $_." unless $used{$_}++;
170         }
171         close T;
172         info "No new commits." unless %used;
173         keys %used;
174 }
175
176 sub all_new_taggers () {
177         my %exists;
178         open(T,'-|','git','for-each-ref','--format=%(objectname)','refs/tags');
179         while (<T>) {
180                 chop;
181                 $exists{$_} = 1;
182         }
183         close T;
184
185         info "Getting taggers of new tags.";
186         my %used;
187         my $obj = $new;
188         my $obj_type = $new_type;
189         while ($obj_type eq 'tag') {
190                 last if $exists{$obj};
191                 $obj_type = '';
192                 open(T,'-|','git','cat-file','tag',$obj);
193                 while (<T>) {
194                         chop;
195                         if (/^object ([a-z0-9]{40})$/) {
196                                 $obj = $1;
197                         } elsif (/^type (.+)$/) {
198                                 $obj_type = $1;
199                         } elsif (s/^tagger //) {
200                                 s/>.*$/>/;
201                                 info "Found $_." unless $used{$_}++;
202                                 last;
203                         }
204                 }
205                 close T;
206         }
207         info "No new tags." unless %used;
208         keys %used;
209 }
210
211 sub check_committers (@) {
212         my @bad;
213         foreach (@_) { push @bad, $_ unless $user_committer{$_}; }
214         if (@bad) {
215                 print STDERR "\n";
216                 print STDERR "You are not $_.\n" foreach (sort @bad);
217                 deny "You cannot push changes not committed by you.";
218         }
219 }
220
221 sub load_diff ($) {
222         my $base = shift;
223         my $d = $diff_cache{$base};
224         unless ($d) {
225                 local $/ = "\0";
226                 my %this_diff;
227                 if ($base =~ /^0{40}$/) {
228                         open(T,'-|','git','ls-tree',
229                                 '-r','--name-only','-z',
230                                 $new) or return undef;
231                         while (<T>) {
232                                 chop;
233                                 $this_diff{$_} = 'A';
234                         }
235                         close T or return undef;
236                 } else {
237                         open(T,'-|','git','diff-tree',
238                                 '-r','--name-status','-z',
239                                 $base,$new) or return undef;
240                         while (<T>) {
241                                 my $op = $_;
242                                 chop $op;
243
244                                 my $path = <T>;
245                                 chop $path;
246
247                                 $this_diff{$path} = $op;
248                         }
249                         close T or return undef;
250                 }
251                 $d = \%this_diff;
252                 $diff_cache{$base} = $d;
253         }
254         return $d;
255 }
256
257 deny "No GIT_DIR inherited from caller" unless $git_dir;
258 deny "Need a ref name" unless $ref;
259 deny "Refusing funny ref $ref" unless $ref =~ s,^refs/,,;
260 deny "Bad old value $old" unless $old =~ /^[a-z0-9]{40}$/;
261 deny "Bad new value $new" unless $new =~ /^[a-z0-9]{40}$/;
262 deny "Cannot determine who you are." unless $this_user;
263
264 $repository_name = File::Spec->rel2abs($git_dir);
265 $repository_name =~ m,/([^/]+)(?:\.git|/\.git)$,;
266 $repository_name = $1;
267 info "Updating in '$repository_name'.";
268
269 my $op;
270 if    ($old =~ /^0{40}$/) { $op = 'C'; }
271 elsif ($new =~ /^0{40}$/) { $op = 'D'; }
272 else                      { $op = 'R'; }
273
274 # This is really an update (fast-forward) if the
275 # merge base of $old and $new is $old.
276 #
277 $op = 'U' if ($op eq 'R'
278         && $ref =~ m,^heads/,
279         && $old eq git_value('merge-base',$old,$new));
280
281 # Load the user's ACL file. Expand groups (user.memberof) one level.
282 {
283         my %data = ('user.committer' => []);
284         parse_config(\%data,$acl_git,$acl_branch,"external/$repository_name.acl");
285
286         %data = (
287                 'user.committer' => $data{'user.committer'},
288                 'user.memberof' => [],
289         );
290         parse_config(\%data,$acl_git,$acl_branch,"users/$this_user.acl");
291
292         %user_committer = map {$_ => $_} @{$data{'user.committer'}};
293         my $rule_key = "repository.$repository_name.allow";
294         my $rules = $data{$rule_key} || [];
295
296         foreach my $group (@{$data{'user.memberof'}}) {
297                 my %g;
298                 parse_config(\%g,$acl_git,$acl_branch,"groups/$group.acl");
299                 my $group_rules = $g{$rule_key};
300                 push @$rules, @$group_rules if $group_rules;
301         }
302
303 RULE:
304         foreach (@$rules) {
305                 while (/\${user\.([a-z][a-zA-Z0-9]+)}/) {
306                         my $k = lc $1;
307                         my $v = $data{"user.$k"};
308                         next RULE unless defined $v;
309                         next RULE if @$v != 1;
310                         next RULE unless defined $v->[0];
311                         s/\${user\.$k}/$v->[0]/g;
312                 }
313
314                 if (/^([AMD ]+)\s+of\s+([^\s]+)\s+for\s+([^\s]+)\s+diff\s+([^\s]+)$/) {
315                         my ($ops, $pth, $ref, $bst) = ($1, $2, $3, $4);
316                         $ops =~ s/ //g;
317                         $pth =~ s/\\\\/\\/g;
318                         $ref =~ s/\\\\/\\/g;
319                         push @path_rules, [$ops, $pth, $ref, $bst];
320                 } elsif (/^([AMD ]+)\s+of\s+([^\s]+)\s+for\s+([^\s]+)$/) {
321                         my ($ops, $pth, $ref) = ($1, $2, $3);
322                         $ops =~ s/ //g;
323                         $pth =~ s/\\\\/\\/g;
324                         $ref =~ s/\\\\/\\/g;
325                         push @path_rules, [$ops, $pth, $ref, $old];
326                 } elsif (/^([CDRU ]+)\s+for\s+([^\s]+)$/) {
327                         my $ops = $1;
328                         my $ref = $2;
329                         $ops =~ s/ //g;
330                         $ref =~ s/\\\\/\\/g;
331                         push @allow_rules, [$ops, $ref];
332                 } elsif (/^for\s+([^\s]+)$/) {
333                         # Mentioned, but nothing granted?
334                 } elsif (/^[^\s]+$/) {
335                         s/\\\\/\\/g;
336                         push @allow_rules, ['U', $_];
337                 }
338         }
339 }
340
341 if ($op ne 'D') {
342         $new_type = git_value('cat-file','-t',$new);
343
344         if ($ref =~ m,^heads/,) {
345                 deny "$ref must be a commit." unless $new_type eq 'commit';
346         } elsif ($ref =~ m,^tags/,) {
347                 deny "$ref must be an annotated tag." unless $new_type eq 'tag';
348         }
349
350         check_committers (all_new_committers);
351         check_committers (all_new_taggers) if $new_type eq 'tag';
352 }
353
354 info "$this_user wants $op for $ref";
355 foreach my $acl_entry (@allow_rules) {
356         my ($acl_ops, $acl_n) = @$acl_entry;
357         next unless $acl_ops =~ /^[CDRU]+$/; # Uhh.... shouldn't happen.
358         next unless $acl_n;
359         next unless $op =~ /^[$acl_ops]$/;
360         next unless match_string $acl_n, $ref;
361
362         # Don't test path rules on branch deletes.
363         #
364         grant "Allowed by: $acl_ops for $acl_n" if $op eq 'D';
365
366         # Aggregate matching path rules; allow if there aren't
367         # any matching this ref.
368         #
369         my %pr;
370         foreach my $p_entry (@path_rules) {
371                 my ($p_ops, $p_n, $p_ref, $p_bst) = @$p_entry;
372                 next unless $p_ref;
373                 push @{$pr{$p_bst}}, $p_entry if match_string $p_ref, $ref;
374         }
375         grant "Allowed by: $acl_ops for $acl_n" unless %pr;
376
377         # Allow only if all changes against a single base are
378         # allowed by file path rules.
379         #
380         my @bad;
381         foreach my $p_bst (keys %pr) {
382                 my $diff_ref = load_diff $p_bst;
383                 deny "Cannot difference trees." unless ref $diff_ref;
384
385                 my %fd = %$diff_ref;
386                 foreach my $p_entry (@{$pr{$p_bst}}) {
387                         my ($p_ops, $p_n, $p_ref, $p_bst) = @$p_entry;
388                         next unless $p_ops =~ /^[AMD]+$/;
389                         next unless $p_n;
390
391                         foreach my $f_n (keys %fd) {
392                                 my $f_op = $fd{$f_n};
393                                 next unless $f_op;
394                                 next unless $f_op =~ /^[$p_ops]$/;
395                                 delete $fd{$f_n} if match_string $p_n, $f_n;
396                         }
397                         last unless %fd;
398                 }
399
400                 if (%fd) {
401                         push @bad, [$p_bst, \%fd];
402                 } else {
403                         # All changes relative to $p_bst were allowed.
404                         #
405                         grant "Allowed by: $acl_ops for $acl_n diff $p_bst";
406                 }
407         }
408
409         foreach my $bad_ref (@bad) {
410                 my ($p_bst, $fd) = @$bad_ref;
411                 print STDERR "\n";
412                 print STDERR "Not allowed to make the following changes:\n";
413                 print STDERR "(base: $p_bst)\n";
414                 foreach my $f_n (sort keys %$fd) {
415                         print STDERR "  $fd->{$f_n} $f_n\n";
416                 }
417         }
418         deny "You are not permitted to $op $ref";
419 }
420 close A;
421 deny "You are not permitted to $op $ref";