+#! /usr/bin/perl
+
+use autodie qw(:all);
+
+use File::Find;
+use File::Path qw(make_path remove_tree);
+use POSIX qw(:errno_h);
+
+use Data::Dumper;
+
+## Set up Gitolite's various things.
+BEGIN {
+ die "GL_RC unset" unless exists $ENV{GL_RC};
+ die "GL_BINDIR unset" unless exists $ENV{GL_BINDIR};
+ unshift @INC, $ENV{GL_BINDIR};
+}
+use gitolite_rc;
+use gitolite;
+
+###--------------------------------------------------------------------------
+### Utility functions.
+
+sub indent_length ($) {
+ my ($s) = @_;
+ ## Return the width of the initial indent of S, in columns, counting tabs
+ ## as an indent to the next multiple of eight.
+
+ my ($ind) = $s =~ /^(\s+)/;
+ my $n = length $ind;
+ my $x = 0;
+
+ for (my $i = 0; $i < $n; $i++) {
+ if (substr($ind, $i, 1) eq "\t") { $x = ($x + 8)&~7; }
+ else { $x++; }
+ }
+ return $x;
+}
+
+sub trim_indent ($$) {
+ my ($s, $n) = @_;
+ ## Return the string S, minus initial characters as far as (but in no case
+ ## exceeding) column N, counting tabs as an indent to the next multiple of
+ ## eight.
+
+ my $x = 0;
+ my ($y, $i);
+
+ for ($i = 0; $i < length $s; $i++) {
+ if (substr($s, $i, 1) eq "\t") { $y = ($x + 8)&~7; }
+ else { $y = $x + 1; }
+ last if $y >= $n;
+ $x = $y;
+ }
+ return substr $s, $y == $n ? $i + 1 : $i;
+}
+
+sub arg (\@$) {
+ my ($a, $what) = @_;
+ ## Fetch the next argument from A; report an error that we don't have WHAT
+ ## if we run out.
+
+ die "missing $what\n" unless @$a;
+ return shift @$a;
+}
+
+###--------------------------------------------------------------------------
+### Configuration file.
+
+sub commit_confkey ($$@) {
+ my ($h, $k, @lines) = @_;
+ ## Store the configuration value LINES in the hash H, under key K.
+ ##
+ ## The longest common sequence of whitespace is trimmed from the LINES (as
+ ## measured using `indent_length'), and then they're concatenated with
+ ## newlines between.
+
+ return unless defined $k;
+
+ shift @lines if $lines[0] eq "";
+ pop @lines while @lines && $lines[-1] eq "";
+
+ my $ind = undef;
+ for my $l (@lines) {
+ next if $l =~ /^\s*$/;
+ my $n = indent_length $l;
+ if (!defined($ind) || $n < $ind) { $ind = $n; }
+ }
+ $h->{$k} = join "\n", map { trim_indent $_, $ind } @lines;
+}
+
+sub read_config ($) {
+ my ($conf) = @_;
+ ## Read configuration from the file CONF, and return a two-level hash
+ ## %conf{GROUP}{KEY} representing it.
+
+ my %c;
+
+ open my $fh, "<", $conf;
+ my $line = <$fh>;
+ my $n = 0;
+ my ($h, $k);
+ my @acc;
+
+ $h = \%{$c{""}};
+ while (defined $line) {
+ chomp $line; $n++;
+ if ($line =~ /^([;\#])/) { }
+ elsif ($line =~ /^\s*\[\s*([-_:\w]+)\s*\]\s*$/) {
+ commit_confkey $h, $k, @acc;
+ $h = \%{$c{$1}};
+ undef $k;
+ } elsif ($line =~ /^\s/) {
+ defined $k or die "$conf:$n: no line to continue\n";
+ push @acc, $line;
+ } elsif ($line =~ /^\s*$/) {
+ push @acc, $line if defined $k;
+ } elsif ($line =~ /^([-\/.%\w]+)\s*[:=]\s*(\S.*|)$/) {
+ commit_confkey $h, $k, @acc;
+ $k = $1;
+ @acc = ($2);
+ } else {
+ die "$conf:$n: invalid config line\n";
+ }
+ $line = <$fh>;
+ }
+ commit_confkey $h, $k, @acc;
+ return %c;
+}
+
+sub conf_var ($$;$) {
+ my ($g, $v, $d) = @_;
+ ## Return the value for V in config group G, or return D by default.
+ ## If D is omitted then report an error.
+
+ my $r = $C{$g}{$v};
+ $r = $C{""}{$v} unless defined $r || $g eq "";
+ $r = $d unless defined $r;
+ die "missing config variable `$g/$v'" unless defined $r;
+ return $r;
+}
+
+###--------------------------------------------------------------------------
+### Updating a configuration repository.
+
+our (%G, %U);
+
+sub subst_user ($$$) {
+ my ($g, $u, $s) = @_;
+ ## Return S, with appropriate substitutions made.
+
+ my %map = ( "G" => $g,
+ "U" => $u,
+ "%" => "%" );
+ $s =~ s/\%(.)/$map{$1} || "\%$1"/eg;
+ return $s;
+}
+
+sub check_user_name ($$) {
+ my ($g, $u) = @_;
+ ## Complain if U isn't a valid user name for group G.
+
+ my $pat = conf_var "conf:$g", "userpat", "[-_0-9a-z]+";
+ die "bad user name `$u'\n" unless $u =~ /^$pat$/;
+}
+
+sub write_conffiles ($$) {
+ my ($g, $u) = @_;
+ ## Write the necessary files for a user U in group G.
+
+ my $ff = $C{"files:$g"};
+ die "unknown group `$g'\n" unless $ff;
+
+ for my $f (keys %$ff) {
+ my $fn = subst_user $g, $u, $f;
+ if ((my $d = $fn) =~ s:/[^/]+$::) { make_path $d; }
+ open my $fh, ">", "$fn.new";
+ print $fh subst_user($g, $u, $ff->{$f}), "\n";
+ close $fh;
+ rename "$fn.new", $fn;
+ }
+}
+
+sub delete_conffiles ($$) {
+ my ($g, $u) = @_;
+ ## Delete configuration files for a user U in group G.
+
+ my $ff = $C{"files:$g"};
+ die "unknown group `$g'\n" unless $ff;
+
+ for my $f (keys %$ff) {
+ my $fn = subst_user $g, $u, $f;
+ unlink $fn;
+ }
+}
+
+sub parse_userinfo_word ($@) {
+ my ($k, @a) = @_;
+ ## Helper for `read_userinfo_file': return the only word from its argument
+ ## list.
+
+ die "`$k' wants a single argument\n" unless @a == 1;
+ return $a[0];
+}
+
+sub parse_userinfo_list ($@) {
+ my ($k, @a) = @_;
+ ## Helper for `read_userinfo_file': return the remaining arguments as an
+ ## arrayref.
+
+ return \@a;
+}
+
+## Mapping userinfo file tags to helper functions which parse their
+## arguments. The helpers take arguments TAG, ARGS ... and are expected to
+## return a properly Perlish value to be stored in the userinfo hash.
+our %USERINFO = ( user => \&parse_userinfo_word,
+ group => \&parse_userinfo_word,
+ path => \&parse_userinfo_list );
+
+sub read_userinfo_file ($) {
+ my ($fn) = @_;
+ ## Parse a userinfo file, returning the results as a hashref.
+
+ my $fh;
+ eval { open $fh, "<", "glau.info/$fn"; };
+ if (!$@) { }
+ elsif ($@->isa("autodie::exception") && $@->errno == ENOENT) {
+ return undef;
+ } else {
+ die;
+ }
+
+ my %i;
+ while (<$fh>) {
+ my @w = split;
+ next unless @w;
+ my $k = shift @w;
+ die "INTERNAL: unknown userinfo tag `$k'" unless $USERINFO{$k};
+ $i{$k} = &{$USERINFO{$k}}($k, @w);
+ }
+ for my $k (keys %USERINFO) {
+ die "INTERNAL: missing userinfo tag `$k'" unless exists $i{$k};
+ }
+ return \%i;
+}
+
+sub decorated_user_name ($$) {
+ my ($g, $u) = @_;
+ ## Take a raw group G and user name U, and return the Gitolite-facing
+ ## decorated user name.
+
+ die "unknown group `$g'\n" unless $C{"conf:$g"};
+ return subst_user $g, $u, conf_var "conf:$g", "decorate", "%U";
+}
+
+sub read_userinfo ($$) {
+ my ($g, $u) = @_;
+ ## Read and return a userinfo hash for the given group/user combination.
+
+ my $fn = decorated_user_name $g, $u;
+ return read_userinfo_file $fn;
+}
+
+sub check_userinfo_tags ($@) {
+ my ($i, @must) = @_;
+ ## Check that the userinfo I has all of the necessary tags, and nothing
+ ## else.
+
+ @must = keys %USERINFO unless @must;
+ for my $k (@must)
+ { die "INTERNAL: missing userinfo tag `$k'" unless exists $i->{$k}; }
+ for my $k (keys %$i)
+ { die "INTERNAL: unexpected userinfo tag `$k'" unless $USERINFO{$k}; }
+}
+
+sub write_userinfo (+;$) {
+ my ($i, $dir) = @_;
+ ## Create a new userinfo file for the information I, writing it to DIR.
+
+ $dir //= "glau.info";
+ check_userinfo_tags $i;
+
+ make_path $dir;
+ my $fn = "$dir/" . decorated_user_name $i->{group}, $i->{user};
+ open my $fh, ">", $fn;
+ for my $k (keys %$i) {
+ my $x = $i->{$k};
+ my $t = ref $x;
+ if ($t eq "ARRAY") { printf $fh "%s %s\n", $k, join " ", @$x; }
+ elsif ($t eq "") { printf $fh "%s %s\n", $k, $x; }
+ else { die "INTERNAL: unexpected ref type `$t' in user info"; }
+ }
+ close $fh;
+}
+
+sub delete_userinfo (+) {
+ my ($i) = @_;
+ ## Create a new userinfo file for the information I.
+
+ check_userinfo_tags $i, "user", "group";
+ unlink "glau.info/" . decorated_user_name $i->{group}, $i->{user};
+}
+
+sub map_allusers (&) {
+ my ($proc) = @_;
+ ## Call PROC(I) for each userinfo known to the system.
+
+ opendir my $d, "glau.info";
+ while (my $f = readdir $d) {
+ next if $f eq "." || $f eq "..";
+ &$proc(read_userinfo_file $f);
+ }
+}
+
+sub map_userkeys (&$$) {
+ my ($proc, $g, $u) = @_;
+ ## Call PROC(KI) for each key known for the user U in group G.
+ ##
+ ## The KI argument is a hashref:
+ ##
+ ## keyid The keyid, with initial `@'.
+ ## fn The leaf filename, relative to the current directory.
+ ## path The full filename, from the top of the admin tree.
+
+ my $fn = decorated_user_name $g, $u;
+ find sub {
+ &$proc({ fn => $_, path => File::Find::name,
+ keyid => $3 })
+ if -f $_ && /^(zzz-marked-for-(add|del)-|)\Q$fn\E(\@[^.]+|)\.pub$/;
+ }, "keydir";
+}
+
+sub existing_keyids ($$) {
+ my ($g, $u) = @_;
+ ## Return the existing keyids for a user U in group G.
+
+ my @k;
+ map_userkeys { push @k, $_[0]->{keyid} } $g, $u;
+ return @k;
+}
+
+sub write_userkey ($$$$) {
+ my ($g, $u, $keyid, $k) = @_;
+ ## Write the key K for a user U in group G, with a given KEYID.
+ ## The key should be a literal string, including trailing newline.
+
+ make_path "keydir";
+ open my $fh, ">",
+ sprintf "keydir/%s%s.pub", decorated_user_name($g, $u), $keyid;
+ print $fh $k;
+ close $fh;
+}
+
+sub delete_userkeys ($$) {
+ my ($g, $u) = @_;
+ ## Delete all of a user's keys.
+
+ map_userkeys { unlink $_[0]->{fn} } $g, $u;
+}
+
+sub refresh_conffiles () {
+ ## Rewrite all of the configuration files we're responsible for.
+
+ for my $d (split " ", conf_var "", "confdirs") { remove_tree $d; }
+ make_path "glau.info-new";
+ map_allusers {
+ my ($i) = @_;
+ my ($g, $u) = @{$i}{"group", "user"};
+ write_conffiles $g, $u;
+ write_userinfo $i, "glau.info-new";
+ };
+ remove_tree "glau.info";
+ rename "glau.info-new", "glau.info";
+}
+
+###--------------------------------------------------------------------------
+### Git things.
+
+our $TMPDIR;
+
+sub create_tmpdir () {
+ ## Create a temporary directory and set `$TMPDIR'.
+
+ ## Maybe we did this already.
+ return if defined $TMPDIR;
+
+ ## We use `~/tmp/glau.PID' as our temporary directory. We decree that
+ ## no other hosts are allowed to use this space at the same time.
+ make_path "$GL_ADMINDIR/tmp";
+ $TMPDIR = "$GL_ADMINDIR/tmp/glau.$$";
+ remove_tree $TMPDIR;
+ mkdir $TMPDIR, 0700;
+}
+
+END { chdir $ENV{HOME}; remove_tree $TMPDIR if defined $TMPDIR; }
+
+sub setup_admin_dir ($) {
+ my ($who) = @_;
+ ## Set up a working tree for the admin repository, on behalf of WHO.
+
+ create_tmpdir;
+
+ chdir $TMPDIR;
+ system "git", "clone", "-q", "$REPO_BASE/gitolite-admin.git", "admin";
+ chdir "admin";
+ system "git", "config", "user.name", "$who/gitolite-adduser";
+}
+
+sub commit_admin_dir ($) {
+ my ($msg) = @_;
+ ## Commit changes to the admin repository, using MSG as the commit message.
+
+ system "git", "add", "-A", ".";
+ ##system "git", "diff", "--cached";
+ system "git", "commit", "-aq", "-m$msg";
+ system "git", "push", "-q";
+}
+
+###--------------------------------------------------------------------------
+### Permission checks.
+
+sub check_adc_access ($$) {
+ my ($g, $u) = @_;
+ ## Check that the caller has permission to modify user U in group G.
+ ##
+ ## This has two parts. Firstly, the caller must have permission to write
+ ## to the fake `EXTCMD/adduser' repository's `NAME/G/U' branch. Secondly,
+ ## we insist that the user isn't already `established'.
+
+ die "GL_USER unset\n" unless exists $ENV{GL_USER};
+
+ ## Check that we have permission.
+ my $rc = check_access "EXTCMD/adduser", "NAME/$g/$u", "W", 1;
+ die "permission $rc\n" if $rc =~ /DENIED/;
+
+ ## Check that the subject user isn't established: i.e., either doesn't
+ ## exist yet, or still has the key that we set up. This allows us to
+ ## modify the key until the subject user declares independence.
+ my $fn = decorated_user_name $g, $u;
+ my @k = existing_keyids $g, $u;
+ die "user `$u' in group `$g' already established\n"
+ if @k && !grep /^\@zzz-glau-\Q$ENV{GL_USER}\E$/, @k;
+}
+
+###--------------------------------------------------------------------------
+### Commands.
+
+package BaseOperation;
+## A base class for operations, implements the minimal protocol.
+##
+## This consists of three methods.
+##
+## CLASS->userv(\@ARG) Construct and return an object to perform the
+## operation given a Userv command-line argument list.
+##
+## CLASS->parse(\@ARG) Construct and return an object to perform the
+## operation given an SSH (ADC) command-line argument
+## list.
+##
+## OP->run() Perform the actual operation.
+
+sub userv { die "not available via userv\n"; }
+sub parse { die "not available as adc\n"; }
+
+package SetOperation;
+use base qw(BaseOperation);
+## Set a user's key. Userv callers can only configure their own `@userv'
+## key. ADC callers can set a key for another user, subject to
+## `check_adc_access'. Reads the `authorized_keys' line from stdin.
+
+sub new {
+ my ($cls, $who, $g, $u, $keyid, $path) = @_;
+ ## Common constructor.
+
+ return bless { who => $who,
+ group => $g,
+ user => $u,
+ keyid => $keyid,
+ path => $path }, $cls;
+}
+
+sub userv {
+ my ($cls, $arg) = @_;
+
+ my $u = $ENV{"USERV_USER"};
+ my $g = ::conf_var "", "uservgroup", "local";
+ return $cls->new($u, $g, $u, "\@userv", []);
+}
+
+sub parse {
+ my ($cls, $arg) = @_;
+
+ my $g = ::arg @$arg, "group name";
+ my $u = ::arg @$arg, "user name";
+ my $who = $ENV{GL_USER};
+ my $i = ::read_userinfo_file $who;
+ die "who are you?\n" unless $i;
+ ::check_adc_access $g, $u;
+ return $cls->new($who, $g, $u, "\@zzz-glau-$who", $i->{path});
+}
+
+sub run {
+ my ($me) = @_;
+
+ my $k;
+ ::check_user_name $me->{group}, $me->{user};
+ my $n = read STDIN, $k, 4096;
+ my @f = split " ", $k;
+ die "malformed public key\n" unless
+ defined $k && $n &&
+ @f == 3 && $k =~ /^[^\n]*\n\z/ &&
+ $f[0] =~ /^(ssh-|ecdsa-)/;
+
+ my $g = $me->{group};
+ my $u = $me->{user};
+
+ ::write_userinfo { group => $g,
+ user => $u,
+ path => [@{$me->{path}}, "$g/$u"] };
+ ::write_conffiles $g, $u;
+ ::write_userkey $g, $u, $me->{keyid}, $k;
+ ::commit_admin_dir "gitolite-adduser for $me->{who}: set key for $g/$u";
+}
+
+package DeleteOperation;
+use base qw(BaseOperation);
+## Only available as an ADC operation: delete an existing unestablished user
+## (subject to `check_adc_access').
+
+sub parse {
+ my ($cls, $arg) = @_;
+
+ my $g = ::arg @$arg, "group name";
+ my $u = ::arg @$arg, "user name";
+ ::check_adc_access $g, $u;
+ return bless { who => $ENV{GL_USER},
+ group => $g,
+ user => $u }, $cls;
+}
+
+sub run {
+ my ($me) = @_;
+
+ my $g = $me->{group};
+ my $u = $me->{user};
+
+ ::delete_userinfo { group => $g, user => $u };
+ ::delete_conffiles $g, $u;
+ ::delete_userkeys $g, $u;
+ ::commit_admin_dir "gitolite-adduser for $me->{who}: delete $g/$u";
+}
+
+package RewriteOperation;
+use base qw(BaseOperation);
+## Rewrite all of the configuration files. This is only available via Userv
+## (and should be restricted to administrators).
+
+sub userv {
+ my ($cls) = @_;
+ return bless { who => $ENV{USERV_USER} }, $cls;
+}
+
+sub run {
+ my ($me) = @_;
+ ::refresh_conffiles;
+ ::commit_admin_dir "gitolite-adduser for $me->{who}: rewrite";
+}
+
+package main;
+
+###--------------------------------------------------------------------------
+### Main dispatch.
+
+(my $prog = $0) =~ s:^.*/::;
+
+eval {
+ our %C = read_config "$GL_ADMINDIR/conf/adduser.conf";
+
+ our %OPMAP = ( set => 'SetOperation',
+ del => 'DeleteOperation',
+ rewrite => 'RewriteOperation' );
+
+ my @a = @ARGV;
+ my $op;
+
+ $ENV{GL_BYPASS_UPDATE_HOOK} = "t";
+ $ENV{GL_ADMINDIR} = $GL_ADMINDIR;
+
+ if (exists $ENV{USERV_USER}) {
+ my $opname = $ENV{USERV_SERVICE};
+ my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n";
+ setup_admin_dir $ENV{USERV_USER};
+ $op = $opcls->userv(\@a);
+ } elsif (exists $ENV{GL_USER}) {
+ my $opname = arg @a, "operation";
+ my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n";
+ setup_admin_dir $ENV{GL_USER};
+ $op = $opcls->parse(\@a);
+ } else {
+ die "unknown service framework\n";
+ }
+
+ die "excess arguments\n" if @a;
+
+ $op->run();
+};
+if ($@) {
+ print STDERR "$prog: $@";
+ exit 1;
+}
+
+###----- That's all, folks --------------------------------------------------
~mdw / glau / commitdiff