6 use File::Path qw(make_path remove_tree);
7 use POSIX qw(:errno_h);
11 ## Set up Gitolite's various things.
13 die "GL_RC unset" unless exists $ENV{GL_RC};
14 die "GL_BINDIR unset" unless exists $ENV{GL_BINDIR};
15 unshift @INC, $ENV{GL_BINDIR};
20 ###--------------------------------------------------------------------------
21 ### Utility functions.
23 sub indent_length ($) {
25 ## Return the width of the initial indent of S, in columns, counting tabs
26 ## as an indent to the next multiple of eight.
28 my ($ind) = $s =~ /^(\s+)/;
32 for (my $i = 0; $i < $n; $i++) {
33 if (substr($ind, $i, 1) eq "\t") { $x = ($x + 8)&~7; }
39 sub trim_indent ($$) {
41 ## Return the string S, minus initial characters as far as (but in no case
42 ## exceeding) column N, counting tabs as an indent to the next multiple of
48 for ($i = 0; $i < length $s; $i++) {
49 if (substr($s, $i, 1) eq "\t") { $y = ($x + 8)&~7; }
54 return substr $s, $y == $n ? $i + 1 : $i;
59 ## Fetch the next argument from A; report an error that we don't have WHAT
62 die "missing $what\n" unless @$a;
66 ###--------------------------------------------------------------------------
67 ### Configuration file.
69 sub commit_confkey ($$@) {
70 my ($h, $k, @lines) = @_;
71 ## Store the configuration value LINES in the hash H, under key K.
73 ## The longest common sequence of whitespace is trimmed from the LINES (as
74 ## measured using `indent_length'), and then they're concatenated with
77 return unless defined $k;
79 shift @lines if $lines[0] eq "";
80 pop @lines while @lines && $lines[-1] eq "";
84 next if $l =~ /^\s*$/;
85 my $n = indent_length $l;
86 if (!defined($ind) || $n < $ind) { $ind = $n; }
88 $h->{$k} = join "\n", map { trim_indent $_, $ind } @lines;
93 ## Read configuration from the file CONF, and return a two-level hash
94 ## %conf{GROUP}{KEY} representing it.
98 open my $fh, "<", $conf;
105 while (defined $line) {
107 if ($line =~ /^([;\#])/) { }
108 elsif ($line =~ /^\s*\[\s*([-_:\w]+)\s*\]\s*$/) {
109 commit_confkey $h, $k, @acc;
112 } elsif ($line =~ /^\s/) {
113 defined $k or die "$conf:$n: no line to continue\n";
115 } elsif ($line =~ /^\s*$/) {
116 push @acc, $line if defined $k;
117 } elsif ($line =~ /^([-\/.%\w]+)\s*[:=]\s*(\S.*|)$/) {
118 commit_confkey $h, $k, @acc;
122 die "$conf:$n: invalid config line\n";
126 commit_confkey $h, $k, @acc;
130 sub conf_var ($$;$) {
131 my ($g, $v, $d) = @_;
132 ## Return the value for V in config group G, or return D by default.
133 ## If D is omitted then report an error.
136 $r = $C{""}{$v} unless defined $r || $g eq "";
137 $r = $d unless defined $r;
138 die "missing config variable `$g/$v'" unless defined $r;
142 ###--------------------------------------------------------------------------
143 ### Updating a configuration repository.
147 sub subst_user ($$$) {
148 my ($g, $u, $s) = @_;
149 ## Return S, with appropriate substitutions made.
151 my %map = ( "G" => $g,
154 $s =~ s/\%(.)/$map{$1} || "\%$1"/eg;
158 sub check_user_name ($$) {
160 ## Complain if U isn't a valid user name for group G.
162 my $pat = conf_var "conf:$g", "userpat", "[-_0-9a-z]+";
163 die "bad user name `$u'\n" unless $u =~ /^$pat$/;
166 sub write_conffiles ($$) {
168 ## Write the necessary files for a user U in group G.
170 my $ff = $C{"files:$g"};
171 die "unknown group `$g'\n" unless $ff;
173 for my $f (keys %$ff) {
174 my $fn = subst_user $g, $u, $f;
175 if ((my $d = $fn) =~ s:/[^/]+$::) { make_path $d; }
176 open my $fh, ">", "$fn.new";
177 print $fh subst_user($g, $u, $ff->{$f}), "\n";
179 rename "$fn.new", $fn;
183 sub delete_conffiles ($$) {
185 ## Delete configuration files for a user U in group G.
187 my $ff = $C{"files:$g"};
188 die "unknown group `$g'\n" unless $ff;
190 for my $f (keys %$ff) {
191 my $fn = subst_user $g, $u, $f;
196 sub parse_userinfo_word ($@) {
198 ## Helper for `read_userinfo_file': return the only word from its argument
201 die "`$k' wants a single argument\n" unless @a == 1;
205 sub parse_userinfo_list ($@) {
207 ## Helper for `read_userinfo_file': return the remaining arguments as an
213 ## Mapping userinfo file tags to helper functions which parse their
214 ## arguments. The helpers take arguments TAG, ARGS ... and are expected to
215 ## return a properly Perlish value to be stored in the userinfo hash.
216 our %USERINFO = ( user => \&parse_userinfo_word,
217 group => \&parse_userinfo_word,
218 path => \&parse_userinfo_list );
220 sub read_userinfo_file ($) {
222 ## Parse a userinfo file, returning the results as a hashref.
225 eval { open $fh, "<", "glau.info/$fn"; };
227 elsif ($@->isa("autodie::exception") && $@->errno == ENOENT) {
238 die "INTERNAL: unknown userinfo tag `$k'" unless $USERINFO{$k};
239 $i{$k} = &{$USERINFO{$k}}($k, @w);
241 for my $k (keys %USERINFO) {
242 die "INTERNAL: missing userinfo tag `$k'" unless exists $i{$k};
247 sub decorated_user_name ($$) {
249 ## Take a raw group G and user name U, and return the Gitolite-facing
250 ## decorated user name.
252 die "unknown group `$g'\n" unless $C{"conf:$g"};
253 return subst_user $g, $u, conf_var "conf:$g", "decorate", "%U";
256 sub read_userinfo ($$) {
258 ## Read and return a userinfo hash for the given group/user combination.
260 my $fn = decorated_user_name $g, $u;
261 return read_userinfo_file $fn;
264 sub check_userinfo_tags ($@) {
266 ## Check that the userinfo I has all of the necessary tags, and nothing
269 @must = keys %USERINFO unless @must;
271 { die "INTERNAL: missing userinfo tag `$k'" unless exists $i->{$k}; }
273 { die "INTERNAL: unexpected userinfo tag `$k'" unless $USERINFO{$k}; }
276 sub write_userinfo (+;$) {
278 ## Create a new userinfo file for the information I, writing it to DIR.
280 $dir //= "glau.info";
281 check_userinfo_tags $i;
284 my $fn = "$dir/" . decorated_user_name $i->{group}, $i->{user};
285 open my $fh, ">", $fn;
286 for my $k (keys %$i) {
289 if ($t eq "ARRAY") { printf $fh "%s %s\n", $k, join " ", @$x; }
290 elsif ($t eq "") { printf $fh "%s %s\n", $k, $x; }
291 else { die "INTERNAL: unexpected ref type `$t' in user info"; }
296 sub delete_userinfo (+) {
298 ## Create a new userinfo file for the information I.
300 check_userinfo_tags $i, "user", "group";
301 unlink "glau.info/" . decorated_user_name $i->{group}, $i->{user};
304 sub map_allusers (&) {
306 ## Call PROC(I) for each userinfo known to the system.
308 opendir my $d, "glau.info";
309 while (my $f = readdir $d) {
310 next if $f eq "." || $f eq "..";
311 &$proc(read_userinfo_file $f);
315 sub map_userkeys (&$$) {
316 my ($proc, $g, $u) = @_;
317 ## Call PROC(KI) for each key known for the user U in group G.
319 ## The KI argument is a hashref:
321 ## keyid The keyid, with initial `@'.
322 ## fn The leaf filename, relative to the current directory.
323 ## path The full filename, from the top of the admin tree.
325 my $fn = decorated_user_name $g, $u;
327 &$proc({ fn => $_, path => File::Find::name,
329 if -f $_ && /^(zzz-marked-for-(add|del)-|)\Q$fn\E(\@[^.]+|)\.pub$/;
333 sub existing_keyids ($$) {
335 ## Return the existing keyids for a user U in group G.
338 map_userkeys { push @k, $_[0]->{keyid} } $g, $u;
342 sub write_userkey ($$$$) {
343 my ($g, $u, $keyid, $k) = @_;
344 ## Write the key K for a user U in group G, with a given KEYID.
345 ## The key should be a literal string, including trailing newline.
349 sprintf "keydir/%s%s.pub", decorated_user_name($g, $u), $keyid;
354 sub delete_userkeys ($$) {
356 ## Delete all of a user's keys.
358 map_userkeys { unlink $_[0]->{fn} } $g, $u;
361 sub refresh_conffiles () {
362 ## Rewrite all of the configuration files we're responsible for.
364 for my $d (split " ", conf_var "", "confdirs") { remove_tree $d; }
365 make_path "glau.info-new";
368 my ($g, $u) = @{$i}{"group", "user"};
369 write_conffiles $g, $u;
370 write_userinfo $i, "glau.info-new";
372 remove_tree "glau.info";
373 rename "glau.info-new", "glau.info";
376 ###--------------------------------------------------------------------------
381 sub create_tmpdir () {
382 ## Create a temporary directory and set `$TMPDIR'.
384 ## Maybe we did this already.
385 return if defined $TMPDIR;
387 ## We use `~/tmp/glau.PID' as our temporary directory. We decree that
388 ## no other hosts are allowed to use this space at the same time.
389 make_path "$GL_ADMINDIR/tmp";
390 $TMPDIR = "$GL_ADMINDIR/tmp/glau.$$";
395 END { chdir $ENV{HOME}; remove_tree $TMPDIR if defined $TMPDIR; }
397 sub setup_admin_dir ($) {
399 ## Set up a working tree for the admin repository, on behalf of WHO.
404 system "git", "clone", "-q", "$REPO_BASE/gitolite-admin.git", "admin";
406 system "git", "config", "user.name", "$who/gitolite-adduser";
409 sub commit_admin_dir ($) {
411 ## Commit changes to the admin repository, using MSG as the commit message.
413 system "git", "add", "-A", ".";
414 ##system "git", "diff", "--cached";
415 system "git", "commit", "-aq", "-m$msg";
416 system "git", "push", "-q";
419 ###--------------------------------------------------------------------------
420 ### Permission checks.
422 sub check_adc_access ($$) {
424 ## Check that the caller has permission to modify user U in group G.
426 ## This has two parts. Firstly, the caller must have permission to write
427 ## to the fake `EXTCMD/adduser' repository's `NAME/G/U' branch. Secondly,
428 ## we insist that the user isn't already `established'.
430 die "GL_USER unset\n" unless exists $ENV{GL_USER};
432 ## Check that we have permission.
433 my $rc = check_access "EXTCMD/adduser", "NAME/$g/$u", "W", 1;
434 die "permission $rc\n" if $rc =~ /DENIED/;
436 ## Check that the subject user isn't established: i.e., either doesn't
437 ## exist yet, or still has the key that we set up. This allows us to
438 ## modify the key until the subject user declares independence.
439 my $fn = decorated_user_name $g, $u;
440 my @k = existing_keyids $g, $u;
441 die "user `$u' in group `$g' already established\n"
442 if @k && !grep /^\@zzz-glau-\Q$ENV{GL_USER}\E$/, @k;
445 ###--------------------------------------------------------------------------
448 package BaseOperation;
449 ## A base class for operations, implements the minimal protocol.
451 ## This consists of three methods.
453 ## CLASS->userv(\@ARG) Construct and return an object to perform the
454 ## operation given a Userv command-line argument list.
456 ## CLASS->parse(\@ARG) Construct and return an object to perform the
457 ## operation given an SSH (ADC) command-line argument
460 ## OP->run() Perform the actual operation.
462 sub userv { die "not available via userv\n"; }
463 sub parse { die "not available as adc\n"; }
465 package SetOperation;
466 use base qw(BaseOperation);
467 ## Set a user's key. Userv callers can only configure their own `@userv'
468 ## key. ADC callers can set a key for another user, subject to
469 ## `check_adc_access'. Reads the `authorized_keys' line from stdin.
472 my ($cls, $who, $g, $u, $keyid, $path) = @_;
473 ## Common constructor.
475 return bless { who => $who,
479 path => $path }, $cls;
483 my ($cls, $arg) = @_;
485 my $u = $ENV{"USERV_USER"};
486 my $g = ::conf_var "", "uservgroup", "local";
487 return $cls->new($u, $g, $u, "\@userv", []);
491 my ($cls, $arg) = @_;
493 my $g = ::arg @$arg, "group name";
494 my $u = ::arg @$arg, "user name";
495 my $who = $ENV{GL_USER};
496 my $i = ::read_userinfo_file $who;
497 die "who are you?\n" unless $i;
498 ::check_adc_access $g, $u;
499 return $cls->new($who, $g, $u, "\@zzz-glau-$who", $i->{path});
506 ::check_user_name $me->{group}, $me->{user};
507 my $n = read STDIN, $k, 4096;
508 my @f = split " ", $k;
509 die "malformed public key\n" unless
511 @f == 3 && $k =~ /^[^\n]*\n\z/ &&
512 $f[0] =~ /^(ssh-|ecdsa-)/;
514 my $g = $me->{group};
517 ::write_userinfo { group => $g,
519 path => [@{$me->{path}}, "$g/$u"] };
520 ::write_conffiles $g, $u;
521 ::write_userkey $g, $u, $me->{keyid}, $k;
522 ::commit_admin_dir "gitolite-adduser for $me->{who}: set key for $g/$u";
525 package DeleteOperation;
526 use base qw(BaseOperation);
527 ## Only available as an ADC operation: delete an existing unestablished user
528 ## (subject to `check_adc_access').
531 my ($cls, $arg) = @_;
533 my $g = ::arg @$arg, "group name";
534 my $u = ::arg @$arg, "user name";
535 ::check_adc_access $g, $u;
536 return bless { who => $ENV{GL_USER},
544 my $g = $me->{group};
547 ::delete_userinfo { group => $g, user => $u };
548 ::delete_conffiles $g, $u;
549 ::delete_userkeys $g, $u;
550 ::commit_admin_dir "gitolite-adduser for $me->{who}: delete $g/$u";
553 package RewriteOperation;
554 use base qw(BaseOperation);
555 ## Rewrite all of the configuration files. This is only available via Userv
556 ## (and should be restricted to administrators).
560 return bless { who => $ENV{USERV_USER} }, $cls;
566 ::commit_admin_dir "gitolite-adduser for $me->{who}: rewrite";
571 ###--------------------------------------------------------------------------
574 (my $prog = $0) =~ s:^.*/::;
577 our %C = read_config "$GL_ADMINDIR/conf/adduser.conf";
579 our %OPMAP = ( set => 'SetOperation',
580 del => 'DeleteOperation',
581 rewrite => 'RewriteOperation' );
586 $ENV{GL_BYPASS_UPDATE_HOOK} = "t";
587 $ENV{GL_ADMINDIR} = $GL_ADMINDIR;
589 if (exists $ENV{USERV_USER}) {
590 my $opname = $ENV{USERV_SERVICE};
591 my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n";
592 setup_admin_dir $ENV{USERV_USER};
593 $op = $opcls->userv(\@a);
594 } elsif (exists $ENV{GL_USER}) {
595 my $opname = arg @a, "operation";
596 my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n";
597 setup_admin_dir $ENV{GL_USER};
598 $op = $opcls->parse(\@a);
600 die "unknown service framework\n";
603 die "excess arguments\n" if @a;
608 print STDERR "$prog: $@";
612 ###----- That's all, folks --------------------------------------------------