mdw@git.distorted.org.uk Git - glau/blob - adduser

   1 #! /usr/bin/perl
   2
   3 use autodie qw(:all);
   4
   5 use File::Find;
   6 use File::Path qw(make_path remove_tree);
   7 use POSIX qw(:errno_h);
   8
   9 use Data::Dumper;
  10
  11 ## Set up Gitolite's various things.
  12 BEGIN {
  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};
  16 }
  17 use gitolite_rc;
  18 use gitolite;
  19
  20 ###--------------------------------------------------------------------------
  21 ### Utility functions.
  22
  23 sub indent_length ($) {
  24   my ($s) = @_;
  25   ## Return the width of the initial indent of S, in columns, counting tabs
  26   ## as an indent to the next multiple of eight.
  27
  28   my ($ind) = $s =~ /^(\s+)/;
  29   my $n = length $ind;
  30   my $x = 0;
  31
  32   for (my $i = 0; $i < $n; $i++) {
  33     if (substr($ind, $i, 1) eq "\t") { $x = ($x + 8)&~7; }
  34     else { $x++; }
  35   }
  36   return $x;
  37 }
  38
  39 sub trim_indent ($$) {
  40   my ($s, $n) = @_;
  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
  43   ## eight.
  44
  45   my $x = 0;
  46   my ($y, $i);
  47
  48   for ($i = 0; $i < length $s; $i++) {
  49     if (substr($s, $i, 1) eq "\t") { $y = ($x + 8)&~7; }
  50     else { $y = $x + 1; }
  51     last if $y >= $n;
  52     $x = $y;
  53   }
  54   return substr $s, $y == $n ? $i + 1 : $i;
  55 }
  56
  57 sub arg (\@$) {
  58   my ($a, $what) = @_;
  59   ## Fetch the next argument from A; report an error that we don't have WHAT
  60   ## if we run out.
  61
  62   die "missing $what\n" unless @$a;
  63   return shift @$a;
  64 }
  65
  66 ###--------------------------------------------------------------------------
  67 ### Configuration file.
  68
  69 sub commit_confkey ($$@) {
  70   my ($h, $k, @lines) = @_;
  71   ## Store the configuration value LINES in the hash H, under key K.
  72   ##
  73   ## The longest common sequence of whitespace is trimmed from the LINES (as
  74   ## measured using `indent_length'), and then they're concatenated with
  75   ## newlines between.
  76
  77   return unless defined $k;
  78
  79   shift @lines if $lines[0] eq "";
  80   pop @lines while @lines && $lines[-1] eq "";
  81
  82   my $ind = undef;
  83   for my $l (@lines) {
  84     next if $l =~ /^\s*$/;
  85     my $n = indent_length $l;
  86     if (!defined($ind) || $n < $ind) { $ind = $n; }
  87   }
  88   $h->{$k} = join "\n", map { trim_indent $_, $ind } @lines;
  89 }
  90
  91 sub read_config ($) {
  92   my ($conf) = @_;
  93   ## Read configuration from the file CONF, and return a two-level hash
  94   ## %conf{GROUP}{KEY} representing it.
  95
  96   my %c;
  97
  98   open my $fh, "<", $conf;
  99   my $line = <$fh>;
 100   my $n = 0;
 101   my ($h, $k);
 102   my @acc;
 103
 104   $h = \%{$c{""}};
 105   while (defined $line) {
 106     chomp $line; $n++;
 107     if ($line =~ /^([;\#])/) { }
 108     elsif ($line =~ /^\s*\[\s*([-_:\w]+)\s*\]\s*$/) {
 109       commit_confkey $h, $k, @acc;
 110       $h = \%{$c{$1}};
 111       undef $k;
 112     } elsif ($line =~ /^\s/) {
 113       defined $k or die "$conf:$n: no line to continue\n";
 114       push @acc, $line;
 115     } elsif ($line =~ /^\s*$/) {
 116       push @acc, $line if defined $k;
 117     } elsif ($line =~ /^([-\/.%\w]+)\s*[:=]\s*(\S.*|)$/) {
 118       commit_confkey $h, $k, @acc;
 119       $k = $1;
 120       @acc = ($2);
 121     } else {
 122       die "$conf:$n: invalid config line\n";
 123     }
 124     $line = <$fh>;
 125   }
 126   commit_confkey $h, $k, @acc;
 127   return %c;
 128 }
 129
 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.
 134
 135   my $r = $C{$g}{$v};
 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;
 139   return $r;
 140 }
 141
 142 ###--------------------------------------------------------------------------
 143 ### Updating a configuration repository.
 144
 145 our (%G, %U);
 146
 147 sub subst_user ($$$) {
 148   my ($g, $u, $s) = @_;
 149   ## Return S, with appropriate substitutions made.
 150
 151   my %map = ( "G" => $g,
 152               "U" => $u,
 153               "%" => "%" );
 154   $s =~ s/\%(.)/$map{$1} || "\%$1"/eg;
 155   return $s;
 156 }
 157
 158 sub check_user_name ($$) {
 159   my ($g, $u) = @_;
 160   ## Complain if U isn't a valid user name for group G.
 161
 162   my $pat = conf_var "conf:$g", "userpat", "[-_0-9a-z]+";
 163   die "bad user name `$u'\n" unless $u =~ /^$pat$/;
 164 }
 165
 166 sub write_conffiles ($$) {
 167   my ($g, $u) = @_;
 168   ## Write the necessary files for a user U in group G.
 169
 170   my $ff = $C{"files:$g"};
 171   die "unknown group `$g'\n" unless $ff;
 172
 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";
 178     close $fh;
 179     rename "$fn.new", $fn;
 180   }
 181 }
 182
 183 sub delete_conffiles ($$) {
 184   my ($g, $u) = @_;
 185   ## Delete configuration files for a user U in group G.
 186
 187   my $ff = $C{"files:$g"};
 188   die "unknown group `$g'\n" unless $ff;
 189
 190   for my $f (keys %$ff) {
 191     my $fn = subst_user $g, $u, $f;
 192     unlink $fn;
 193   }
 194 }
 195
 196 sub parse_userinfo_word ($@) {
 197   my ($k, @a) = @_;
 198   ## Helper for `read_userinfo_file': return the only word from its argument
 199   ## list.
 200
 201   die "`$k' wants a single argument\n" unless @a == 1;
 202   return $a[0];
 203 }
 204
 205 sub parse_userinfo_list ($@) {
 206   my ($k, @a) = @_;
 207   ## Helper for `read_userinfo_file': return the remaining arguments as an
 208   ## arrayref.
 209
 210   return \@a;
 211 }
 212
 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 );
 219
 220 sub read_userinfo_file ($) {
 221   my ($fn) = @_;
 222   ## Parse a userinfo file, returning the results as a hashref.
 223
 224   my $fh;
 225   eval { open $fh, "<", "glau.info/$fn"; };
 226   if (!$@) { }
 227   elsif ($@->isa("autodie::exception") && $@->errno == ENOENT) {
 228     return undef;
 229   } else {
 230     die;
 231   }
 232
 233   my %i;
 234   while (<$fh>) {
 235     my @w = split;
 236     next unless @w;
 237     my $k = shift @w;
 238     die "INTERNAL: unknown userinfo tag `$k'" unless $USERINFO{$k};
 239     $i{$k} = &{$USERINFO{$k}}($k, @w);
 240   }
 241   for my $k (keys %USERINFO) {
 242     die "INTERNAL: missing userinfo tag `$k'" unless exists $i{$k};
 243   }
 244   return \%i;
 245 }
 246
 247 sub decorated_user_name ($$) {
 248   my ($g, $u) = @_;
 249   ## Take a raw group G and user name U, and return the Gitolite-facing
 250   ## decorated user name.
 251
 252   die "unknown group `$g'\n" unless $C{"conf:$g"};
 253   return subst_user $g, $u, conf_var "conf:$g", "decorate", "%U";
 254 }
 255
 256 sub read_userinfo ($$) {
 257   my ($g, $u) = @_;
 258   ## Read and return a userinfo hash for the given group/user combination.
 259
 260   my $fn = decorated_user_name $g, $u;
 261   return read_userinfo_file $fn;
 262 }
 263
 264 sub check_userinfo_tags ($@) {
 265   my ($i, @must) = @_;
 266   ## Check that the userinfo I has all of the necessary tags, and nothing
 267   ## else.
 268
 269   @must = keys %USERINFO unless @must;
 270   for my $k (@must)
 271     { die "INTERNAL: missing userinfo tag `$k'" unless exists $i->{$k}; }
 272   for my $k (keys %$i)
 273     { die "INTERNAL: unexpected userinfo tag `$k'" unless $USERINFO{$k}; }
 274 }
 275
 276 sub write_userinfo (+;$) {
 277   my ($i, $dir) = @_;
 278   ## Create a new userinfo file for the information I, writing it to DIR.
 279
 280   $dir //= "glau.info";
 281   check_userinfo_tags $i;
 282
 283   make_path $dir;
 284   my $fn = "$dir/" . decorated_user_name $i->{group}, $i->{user};
 285   open my $fh, ">", $fn;
 286   for my $k (keys %$i) {
 287     my $x = $i->{$k};
 288     my $t = ref $x;
 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"; }
 292   }
 293   close $fh;
 294 }
 295
 296 sub delete_userinfo (+) {
 297   my ($i) = @_;
 298   ## Create a new userinfo file for the information I.
 299
 300   check_userinfo_tags $i, "user", "group";
 301   unlink "glau.info/" . decorated_user_name $i->{group}, $i->{user};
 302 }
 303
 304 sub map_allusers (&) {
 305   my ($proc) = @_;
 306   ## Call PROC(I) for each userinfo known to the system.
 307
 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);
 312   }
 313 }
 314
 315 sub map_userkeys (&$$) {
 316   my ($proc, $g, $u) = @_;
 317   ## Call PROC(KI) for each key known for the user U in group G.
 318   ##
 319   ## The KI argument is a hashref:
 320   ##
 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.
 324
 325   my $fn = decorated_user_name $g, $u;
 326   find sub {
 327     &$proc({ fn => $_, path => File::Find::name,
 328              keyid => $3 })
 329       if -f $_ && /^(zzz-marked-for-(add|del)-|)\Q$fn\E(\@[^.]+|)\.pub$/;
 330   }, "keydir";
 331 }
 332
 333 sub existing_keyids ($$) {
 334   my ($g, $u) = @_;
 335   ## Return the existing keyids for a user U in group G.
 336
 337   my @k;
 338   map_userkeys { push @k, $_[0]->{keyid} } $g, $u;
 339   return @k;
 340 }
 341
 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.
 346
 347   make_path "keydir";
 348   open my $fh, ">",
 349     sprintf "keydir/%s%s.pub", decorated_user_name($g, $u), $keyid;
 350   print $fh $k;
 351   close $fh;
 352 }
 353
 354 sub delete_userkeys ($$) {
 355   my ($g, $u) = @_;
 356   ## Delete all of a user's keys.
 357
 358   map_userkeys { unlink $_[0]->{fn} } $g, $u;
 359 }
 360
 361 sub refresh_conffiles () {
 362   ## Rewrite all of the configuration files we're responsible for.
 363
 364   for my $d (split " ", conf_var "", "confdirs") { remove_tree $d; }
 365   make_path "glau.info-new";
 366   map_allusers {
 367     my ($i) = @_;
 368     my ($g, $u) = @{$i}{"group", "user"};
 369     write_conffiles $g, $u;
 370     write_userinfo $i, "glau.info-new";
 371   };
 372   remove_tree "glau.info";
 373   rename "glau.info-new", "glau.info";
 374 }
 375
 376 ###--------------------------------------------------------------------------
 377 ### Git things.
 378
 379 our $TMPDIR;
 380
 381 sub create_tmpdir () {
 382   ## Create a temporary directory and set `$TMPDIR'.
 383
 384   ## Maybe we did this already.
 385   return if defined $TMPDIR;
 386
 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.$$";
 391   remove_tree $TMPDIR;
 392   mkdir $TMPDIR, 0700;
 393 }
 394
 395 END { chdir $ENV{HOME}; remove_tree $TMPDIR if defined $TMPDIR; }
 396
 397 sub setup_admin_dir ($) {
 398   my ($who) = @_;
 399   ## Set up a working tree for the admin repository, on behalf of WHO.
 400
 401   create_tmpdir;
 402
 403   chdir $TMPDIR;
 404   system "git", "clone", "-q", "$REPO_BASE/gitolite-admin.git", "admin";
 405   chdir "admin";
 406   system "git", "config", "user.name", "$who/gitolite-adduser";
 407 }
 408
 409 sub commit_admin_dir ($) {
 410   my ($msg) = @_;
 411   ## Commit changes to the admin repository, using MSG as the commit message.
 412
 413   system "git", "add", "-A", ".";
 414   ##system "git", "diff", "--cached";
 415   system "git", "commit", "-aq", "-m$msg";
 416   system "git", "push", "-q";
 417 }
 418
 419 ###--------------------------------------------------------------------------
 420 ### Permission checks.
 421
 422 sub check_adc_access ($$) {
 423   my ($g, $u) = @_;
 424   ## Check that the caller has permission to modify user U in group G.
 425   ##
 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'.
 429
 430   die "GL_USER unset\n" unless exists $ENV{GL_USER};
 431
 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/;
 435
 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;
 443 }
 444
 445 ###--------------------------------------------------------------------------
 446 ### Commands.
 447
 448 package BaseOperation;
 449 ## A base class for operations, implements the minimal protocol.
 450 ##
 451 ## This consists of three methods.
 452 ##
 453 ## CLASS->userv(\@ARG)  Construct and return an object to perform the
 454 ##                        operation given a Userv command-line argument list.
 455 ##
 456 ## CLASS->parse(\@ARG)  Construct and return an object to perform the
 457 ##                        operation given an SSH (ADC) command-line argument
 458 ##                        list.
 459 ##
 460 ## OP->run()            Perform the actual operation.
 461
 462 sub userv { die "not available via userv\n"; }
 463 sub parse { die "not available as adc\n"; }
 464
 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.
 470
 471 sub new {
 472   my ($cls, $who, $g, $u, $keyid, $path) = @_;
 473   ## Common constructor.
 474
 475   return bless { who => $who,
 476                  group => $g,
 477                  user => $u,
 478                  keyid => $keyid,
 479                  path => $path }, $cls;
 480 }
 481
 482 sub userv {
 483   my ($cls, $arg) = @_;
 484
 485   my $u = $ENV{"USERV_USER"};
 486   my $g = ::conf_var "", "uservgroup", "local";
 487   return $cls->new($u, $g, $u, "\@userv", []);
 488 }
 489
 490 sub parse {
 491   my ($cls, $arg) = @_;
 492
 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});
 500 }
 501
 502 sub run {
 503   my ($me) = @_;
 504
 505   my $k;
 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
 510     defined $k && $n &&
 511     @f == 3 && $k =~ /^[^\n]*\n\z/ &&
 512     $f[0] =~ /^(ssh-|ecdsa-)/;
 513
 514   my $g = $me->{group};
 515   my $u = $me->{user};
 516
 517   ::write_userinfo { group => $g,
 518                      user => $u,
 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";
 523 }
 524
 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').
 529
 530 sub parse {
 531   my ($cls, $arg) = @_;
 532
 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},
 537                  group => $g,
 538                  user => $u }, $cls;
 539 }
 540
 541 sub run {
 542   my ($me) = @_;
 543
 544   my $g = $me->{group};
 545   my $u = $me->{user};
 546
 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";
 551 }
 552
 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).
 557
 558 sub userv {
 559   my ($cls) = @_;
 560   return bless { who => $ENV{USERV_USER} }, $cls;
 561 }
 562
 563 sub run {
 564   my ($me) = @_;
 565   ::refresh_conffiles;
 566   ::commit_admin_dir "gitolite-adduser for $me->{who}: rewrite";
 567 }
 568
 569 package main;
 570
 571 ###--------------------------------------------------------------------------
 572 ### Main dispatch.
 573
 574 (my $prog = $0) =~ s:^.*/::;
 575
 576 eval {
 577   our %C = read_config "$GL_ADMINDIR/conf/adduser.conf";
 578
 579   our %OPMAP = ( set => 'SetOperation',
 580                  del => 'DeleteOperation',
 581                  rewrite => 'RewriteOperation' );
 582
 583   my @a = @ARGV;
 584   my $op;
 585
 586   $ENV{GL_BYPASS_UPDATE_HOOK} = "t";
 587   $ENV{GL_ADMINDIR} = $GL_ADMINDIR;
 588
 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);
 599   } else {
 600     die "unknown service framework\n";
 601   }
 602
 603   die "excess arguments\n" if @a;
 604
 605   $op->run();
 606 };
 607 if ($@) {
 608   print STDERR "$prog: $@";
 609   exit 1;
 610 }
 611
 612 ###----- That's all, folks --------------------------------------------------