#! /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 --------------------------------------------------