#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;

# === add-auth-keys ===

# part of the gitolite (GL) suite

# (1) - "compiles" ~/.ssh/authorized_keys from the list of pub-keys
# (2) - also "compiles" the user-friendly GL conf file into something easier
#       to parse.  We're doing this because both the gl-auth-command and the
#       (gl-)update hook need this, and it seems easier to do this than
#       replicate the parsing code in both those places.  As a bonus, it's
#       probably more efficient.
# (3) - finally does what I have resisted doing all along -- handle gitweb and
#       git-daemon access.  It won't *setup* gitweb/daemon for you -- you have
#       to that yourself.  What this does is make sure that "repo.git"
#       contains the file "git-daemon-export-ok" (for daemon case) and the
#       line "repo.git" exists in the "projects.list" file (for gitweb case).

# how run:      manual, by GL admin
# when:
#     - anytime a pubkey is added/deleted
#     - anytime gitolite.conf is changed
# input:
#     - GL_CONF (default: ~/.gitolite/gitolite.conf)
#     - GL_KEYDIR (default: ~/.gitolite/keydir)
# output:
#     - ~/.ssh/authorized_keys (dictated by sshd)
#     - GL_CONF_COMPILED (default: ~/.gitolite/gitolite.conf-compiled.pm)
# security:
#     - touches a very critical system file that manages the restrictions on
#       incoming users.  Be sure to audit AUTH_COMMAND and AUTH_OPTIONS (see
#       below) on any change to this script
#     - no security checks within program.  The GL admin runs this manually

# warnings:
#     - if the "start" line exists, but the "end" line does not, you lose the
#       rest of the existing authkey file.  In general, "don't do that (TM)",
#       but we do have a "vim -d" popping up so you can see the changes being
#       made, just in case...

# ----------------------------------------------------------------------------
#       common definitions
# ----------------------------------------------------------------------------

# setup quiet mode if asked; please do not use this when running manually
open STDOUT, ">", "/dev/null" if (@ARGV and shift eq '-q');

our ($GL_ADMINDIR, $GL_CONF, $GL_KEYDIR, $GL_CONF_COMPILED, $REPO_BASE, $REPO_UMASK, $PROJECTS_LIST, $GIT_PATH);

# now that this thing *may* be run via "push to admin", any errors have to
# grab the admin's ATTENTION so he won't miss them among the other messages a
# typical push generates
my $ABRT = "\n\t\t***** ABORTING *****\n       ";
my $WARN = "\n\t\t***** WARNING *****\n       ";

# the common setup module is in the same directory as this running program is
my $bindir = $0;
$bindir =~ s/\/[^\/]+$//;
require "$bindir/gitolite.pm";

# ask where the rc file is, get it, and "do" it
&where_is_rc();
die "$ABRT parse $ENV{GL_RC} failed: " . ($! or $@) unless do $ENV{GL_RC};

# add a custom path for git binaries, if specified
$ENV{PATH} .= ":$GIT_PATH" if $GIT_PATH;

# ----------------------------------------------------------------------------
#       definitions specific to this program
# ----------------------------------------------------------------------------

# command and options for authorized_keys
my $AUTH_COMMAND="$GL_ADMINDIR/src/gl-auth-command";
my $AUTH_OPTIONS="no-port-forwarding,no-X11-forwarding,no-agent-forwarding,no-pty";
# note that REPONAME_PATT allows a "/" also, which USERNAME_PATT doesn't
my $REPONAME_PATT=qr(^\@?[0-9a-zA-Z][0-9a-zA-Z._/-]*$);     # very simple pattern
my $USERNAME_PATT=qr(^\@?[0-9a-zA-Z][0-9a-zA-Z._-]*$);      # very simple pattern

# groups can now represent user groups or repo groups.

# $groups{group}{member} = "master" (or name of fragment file in which the
# group is defined).
my %groups = ();

# %repos has two functions.

# $repos{repo}{R|W}{user} = 1 if user has R (or W) permissions for at least
# one branch in repo.  This is used by the "level 1 check" (see faq)

# $repos{repo}{user} is a list of {ref, perms} pairs.  This is used by the
# level 2 check.  In order to allow "exclude" rules, the order of rules now
# matters, so what used to be entirely "hash of hash of hash" now has a list
# in between :)
my %repos = ();

# <sigh>...  having been forced to use a list as described above, we lose some
# efficiency due to the possibility of the same {ref, perms} pair showing up
# multiple times for the same repo+user.  So...
my %rurp_seen = ();

# catch usernames<->pubkeys mismatches; search for "lint" below
my %user_list = ();

# gitweb descriptions, plain text, keyed by repo
my %desc = ();

# set the umask before creating any files
umask($REPO_UMASK);

# ----------------------------------------------------------------------------
#       subroutines
# ----------------------------------------------------------------------------

sub wrap_chdir {
    chdir($_[0]) or die "$ABRT chdir $_[0] failed: $! at ", (caller)[1], " line ", (caller)[2], "\n";
}

sub wrap_open {
    open (my $fh, $_[0], $_[1]) or die "$ABRT open $_[1] failed: $! at ", (caller)[1], " line ", (caller)[2], "\n" .
            ( $_[2] || '' );    # suffix custom error message if given
    return $fh;
}

sub expand_list
{
    my @list = @_;
    my @new_list = ();

    for my $item (@list)
    {
        # we test with the slightly more relaxed pattern here; we'll catch the
        # "/" in user name thing later; it doesn't affect security anyway
        die "$ABRT bad user or repo name $item\n" unless $item =~ $REPONAME_PATT;
        if ($item =~ /^@/)      # nested group
        {
            die "$ABRT undefined group $item\n" unless $groups{$item};
            # add those names to the list
            push @new_list, sort keys %{ $groups{$item} };
        }
        else
        {
            push @new_list, $item;
        }
    }

    return @new_list;
}

# ----------------------------------------------------------------------------
#       "compile" GL conf
# ----------------------------------------------------------------------------

sub parse_conf_file
{
    my ($conffile, $fragment) = @_;
    # the second arg, $fragment, is passed in as "master" when parsing the
    # main config, and the fragment name when parsing a fragment.  In the
    # latter case, the parser uses that information to ignore (and warn about)
    # any repos in the fragment that are not members of the "repo group" of
    # the same name.
    my %ignored = ();

    my $conf_fh = wrap_open( "<", $conffile );

    # the syntax is fairly simple, so we parse it inline

    my @repos;
    while (<$conf_fh>)
    {
        # normalise whitespace; keeps later regexes very simple
        s/=/ = /;
        s/\s+/ /g;
        s/^ //;
        s/ $//;
        # kill comments
        s/#.*//;
        # and blank lines
        next unless /\S/;

        # user or repo groups
        if (/^(@\S+) = (.*)/)
        {
            # store the members of each group as hash key.  Keep track of when
            # the group was *first* created by using $fragment as the *value*
            do { $groups{$1}{$_} ||= $fragment } for ( expand_list( split(' ', $2) ) );
            # again, we take the more "relaxed" pattern
            die "$ABRT bad group $1\n" unless $1 =~ $REPONAME_PATT;
        }
        # repo(s)
        elsif (/^repo (.*)/)
        {
            # grab the list and expand any @stuff in it
            @repos = split ' ', $1;
            @repos = expand_list ( @repos );
        }
        # actual permission line
        elsif (/^(R|RW|RW\+) (.* )?= (.+)/)
        {
            my $perms = $1;
            my @refs; @refs = split(' ', $2) if $2;
            my @users = split ' ', $3;

            # if no ref is given, this PERM applies to all refs
            @refs = qw(refs/.*) unless @refs;
            # fully qualify refs that dont start with "refs/"; prefix them with
            # "refs/heads/"
            @refs = map { m(^refs/) or s(^)(refs/heads/); $_ } @refs;

            # expand the user list, unless it is just "@all"
            @users = expand_list ( @users )
                unless (@users == 1 and $users[0] eq '@all');
            do  { die "$ABRT bad username $_\n" unless $_ =~ $USERNAME_PATT } for @users;

            # ok, we can finally populate the %repos hash
            for my $repo (@repos)       # each repo in the current stanza
            {
                # if we're processing a delegated config file (not the master
                # config), and if that fragment name is not the same as the
                # current repo
                if ($fragment ne 'master' and $fragment ne $repo)
                {
                    # then the fragment must be a group name and the repo
                    # being processed must be a member of that "@group".
                    # Also, the value of the hash for that combination must be
                    # "master", signifying a group created in the master
                    # config file and not in one of the delegates
                    unless ( ($groups{"\@$fragment"}{$repo} || '') eq 'master')
                    {
                        $ignored{$fragment}{$repo} = 1;
                        next;
                    }
                }
                for my $user (@users)
                {
                    $user_list{$user}++;    # only to catch lint, see later

                    # for 1st level check (see faq/tips doc)
                    $repos{$repo}{R}{$user} = 1 if $perms =~ /R/;
                    $repos{$repo}{W}{$user} = 1 if $perms =~ /W/;

                    # for 2nd level check, store each "ref, perms" pair in order
                    for my $ref (@refs)
                    {
                        push @{ $repos{$repo}{$user} }, { $ref => $perms }
                            unless $rurp_seen{$repo}{$user}{$ref}{$perms}++;
                    }
                }
            }
        }
        # very simple syntax for the gitweb description of repo
        elsif (/^(\S+) = "(.*)"$/)
        {
            my ($repo, $desc) = ($1, $2);
            die "$ABRT bad repo name $repo\n" unless $repo =~ $REPONAME_PATT;
            die "$WARN $fragment attempting to set description for $repo\n" if
                $fragment ne 'master' and $fragment ne $repo and ($groups{"\@$fragment"}{$repo} || '') ne 'master';
            $desc{$repo} = $desc;
        }
        else
        {
            die "$ABRT can't make head or tail of '$_'\n";
        }
    }
    for my $ig (sort keys %ignored)
    {
        warn "\n\t\t***** WARNING *****\n" .
            "\t$ig.conf attempting to set access for " .
            join (", ", sort keys %{ $ignored{$ig} }) . "\n";
    }
}

# parse the main config file
parse_conf_file($GL_CONF, 'master');

# parse any delegated fragments
wrap_chdir($GL_ADMINDIR);
for my $fragment_file (glob("conf/fragments/*.conf"))
{
    my $fragment = $fragment_file;
    $fragment =~ s/^conf\/fragments\/(.*).conf$/$1/;
    parse_conf_file($fragment_file, $fragment);
}

my $compiled_fh = wrap_open( ">", $GL_CONF_COMPILED );
print $compiled_fh Data::Dumper->Dump([\%repos], [qw(*repos)]);
close $compiled_fh or die "$ABRT close compiled-conf failed: $!\n";

# ----------------------------------------------------------------------------
#       any new repos to be created?
# ----------------------------------------------------------------------------

# modern gits allow cloning from an empty repo, so we just create it.  Gitosis
# did not have that luxury, so it was forced to detect the first push and
# create it then

# but it turns out not everyone has "modern" gits :)
my $git_version = `git --version`;
my ($gv_maj, $gv_min, $gv_patchrel) = ($git_version =~ m/git version (\d+)\.(\d+)\.(\d+)/);
die "$ABRT I can't understand $git_version\n" unless ($gv_maj >= 1);
$git_version = $gv_maj*10000 + $gv_min*100 + $gv_patchrel;  # now it's "normalised"
my $git_too_old = 0;

# repo-base needs to be an absolute path for this loop to work right
# so if it was not already absolute, prefix $HOME.
my $repo_base_abs = ( $REPO_BASE =~ m(^/) ? $REPO_BASE : "$ENV{HOME}/$REPO_BASE" );
wrap_chdir("$repo_base_abs");
for my $repo (keys %repos)
{
    unless (-d "$repo.git")
    {
        system("mkdir", "-p", "$repo.git") and die "$ABRT mkdir $repo.git failed: $!\n";
            # erm, note that's "and die" not "or die" as is normal in perl
        wrap_chdir("$repo.git");
        system("git --bare init");
        # propagate our own, plus any local admin-defined, hooks
        system("cp $GL_ADMINDIR/src/hooks/* hooks/");
        chmod 0755, "hooks/update";
        wrap_chdir("$repo_base_abs");
        $git_too_old++ if $git_version < 10602;     # that's 1.6.2 to you
    }
}
warn "\n\t\t***** WARNING *****\n" .
    "\tyour git version is older than 1.6.2\n" .
    "\tgitolite will work but you MUST read the section on\n" .
    "\t\"git version dependency\" in doc/3-faq-tips-etc.mkd\n"
    if $git_too_old;

# ----------------------------------------------------------------------------
#       handle gitweb and daemon
# ----------------------------------------------------------------------------

# How you specify gitweb and daemon access is quite different from gitosis.  I
# just assume you'll never have any *real* users called "gitweb" or "daemon"
# :-)  These are now "pseduo users" -- giving them "R" access to a repo is all
# you have to do

wrap_chdir("$repo_base_abs");

# get the current project list; note that the file may not yet exist if no
# gitweb access has been specified so far
my %projlist = ();
if (-f $PROJECTS_LIST) {
    my $projlist_fh = wrap_open( "<", $PROJECTS_LIST);
    while(<$projlist_fh>) {
        chomp;
        $projlist{$_} = 1;
    }
    close $projlist_fh;
}
my $projlist_changed = 0;

# daemons first...
for my $repo (sort keys %repos) {
    my $export_ok = "$repo.git/git-daemon-export-ok";
    if ($repos{$repo}{'R'}{'daemon'}) {
        unless (-f $export_ok) {
            system("touch $export_ok");
            print "daemon add $repo.git\n";
        }
    } else {
        if (-f $export_ok) {
            unlink($export_ok);
            print "daemon del $repo.git\n";
        }
    }
}

# ...then gitwebs
for my $repo (sort keys %repos) {
    my $desc_file = "$repo.git/description";
    # note: having a description also counts as enabling gitweb
    if ($repos{$repo}{'R'}{'gitweb'} or $desc{$repo}) {
        unless ($projlist{"$repo.git"}) {
            # not in the old list; add it to the new one
            $projlist{"$repo.git"} = 1;
            $projlist_changed = 1;
            print "gitweb add $repo.git\n";
        }
        # add the description file; no messages to user or error checking :)
        $desc{$repo} and open(DESC, ">", $desc_file) and print DESC "$desc{$repo}\n" and close DESC;
    } else {
        if ($projlist{"$repo.git"}) {
            # delete it from new list
            delete $projlist{"$repo.git"};
            $projlist_changed = 1;
            print "gitweb del $repo.git\n";
        }
        # delete the description file; no messages to user or error checking :)
        unlink $desc_file;
    }
}

# has there been a change in the gitweb projects list?
if ($projlist_changed) {
    print "updating gitweb project list $PROJECTS_LIST\n";
    my $projlist_fh = wrap_open( ">", $PROJECTS_LIST);
    print $projlist_fh join("\n", sort keys %projlist), "\n" if %projlist;
    close $projlist_fh;
}

# ----------------------------------------------------------------------------
#       "compile" ssh authorized_keys
# ----------------------------------------------------------------------------

my $authkeys_fh = wrap_open( "<", $ENV{HOME} . "/.ssh/authorized_keys",
    "\tFor security reasons, gitolite will not *create* this file if it does\n" .
    "\tnot already exist.  Please see the \"admin\" document for details\n");
my $newkeys_fh = wrap_open( ">", $ENV{HOME} . "/.ssh/new_authkeys" );
# save existing authkeys minus the GL-added stuff
while (<$authkeys_fh>)
{
    print $newkeys_fh $_ unless (/^# gito(sis-)?lite start/../^# gito(sis-)?lite end/);
}

# add our "start" line, each key on its own line (prefixed by command and
# options, in the standard ssh authorized_keys format), then the "end" line.
print $newkeys_fh "# gitolite start\n";
wrap_chdir($GL_KEYDIR);
for my $pubkey (glob("*"))
{
    # lint check 1
    unless ($pubkey =~ /\.pub$/)
    {
        print STDERR "WARNING: pubkey files should end with \".pub\", ignoring $pubkey\n";
        next;
    }
    my $user = $pubkey; $user =~ s/(\@.+)?\.pub$//;
    # lint check 2
    print STDERR "WARNING: pubkey $pubkey exists but user $user not in config\n"
        unless $user_list{$user};
    $user_list{$user} = 'has pubkey';
    print $newkeys_fh "command=\"$AUTH_COMMAND $user\",$AUTH_OPTIONS ";
    # apparently some pubkeys don't end in a newline...
    my $pubkey_content = `cat $pubkey`;
    $pubkey_content =~ s/\s*$/\n/;
    print $newkeys_fh $pubkey_content;
}
# lint check 3; a little more severe than the first two I guess...
for my $user (sort keys %user_list)
{
    next if $user =~ /^(gitweb|daemon|\@all)$/ or $user_list{$user} eq 'has pubkey';
    print STDERR "$WARN user $user in config, but has no pubkey!\n";
}

print $newkeys_fh "# gitolite end\n";
close $newkeys_fh or die "$ABRT close newkeys failed: $!\n";

# all done; overwrite the file (use cat to avoid perm changes)
system("cat $ENV{HOME}/.ssh/authorized_keys > $ENV{HOME}/.ssh/old_authkeys");
system("cat $ENV{HOME}/.ssh/new_authkeys > $ENV{HOME}/.ssh/authorized_keys");
system("rm  $ENV{HOME}/.ssh/new_authkeys");