gitolite.pm

# lots of common routines

package gitolite;
use Exporter 'import';
@EXPORT = qw(
    can_read
    check_access
    check_ref
    check_repo_write_enabled
    cli_repo_rights
    dbg
    list_phy_repos
    ln_sf
    log_it
    new_repo
    new_wild_repo
    repo_rights
    run_custom_command
    setup_authkeys
    setup_daemon_access
    setup_git_configs
    setup_gitweb_access
    shell_out
    special_cmd
    try_adc
    wrap_chdir
    wrap_open
    wrap_print
);
@EXPORT_OK = qw(
    %repos
    %groups
    %git_configs
    %split_conf
);

use strict;
use warnings;

use Data::Dumper;
$Data::Dumper::Deepcopy = 1;
$|++;

# ----------------------------------------------------------------------------
#       find the rc file, then pull the libraries
# ----------------------------------------------------------------------------

BEGIN {
    die "ENV GL_RC not set\n" unless $ENV{GL_RC};
    die "ENV GL_BINDIR not set\n" unless $ENV{GL_BINDIR};
}

use lib $ENV{GL_BINDIR};
use gitolite_rc;

# ----------------------------------------------------------------------------
#       the big data structures we care about
# ----------------------------------------------------------------------------

our %repos;
our %groups;
our %git_configs;
our %split_conf;
our $data_version;

# the following are read in from individual repo's gl-conf files, if present
our %one_repo;          # corresponds to what goes into %repos
our %one_git_config;    # ditto for %git_configs

# ----------------------------------------------------------------------------
#       convenience subs
# ----------------------------------------------------------------------------

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 wrap_print {
    my ($file, $text) = @_;
    my $fh = wrap_open(">", $file);
    print $fh $text;
    close($fh);
}

sub add_del_line {
    my ($line, $file, $flag) = @_;
    my $contents;

    local $/ = undef;
    my $fh = wrap_open("<", $file);
    $contents = <$fh>;
    $contents =~ s/\s+$/\n/;

    if ($flag and $contents !~ /^\Q$line\E$/m) {
        # add line if it doesn't exist
        $contents .= "$line\n";
        wrap_print($file, $contents);
    }
    if (not $flag and $contents =~ /^\Q$line\E$/m) {
        $contents =~ s/^\Q$line\E(\n|$)//m;
        wrap_print($file, $contents);
    }
}

sub dbg {
    use Data::Dumper;
    for my $i (@_) {
        print STDERR "DBG: " .  Dumper($i);
    }
}

sub log_it {
    my ($ip, $logmsg);
    open my $log_fh, ">>", $ENV{GL_LOG} or die "open log failed: $!\n";
    # first space sep field is client ip, per "man ssh"
    ($ip = $ENV{SSH_CONNECTION} || '(no-IP)') =~ s/ .*//;
    # the first part of logmsg is the actual command used; it's either passed
    # in via arg1, or picked up from SSH_ORIGINAL_COMMAND
    $logmsg = $_[0] || $ENV{SSH_ORIGINAL_COMMAND}; shift;
    # the rest of it upto the caller; we just dump it into the logfile
    $logmsg .= "\t@_" if @_;
    # erm... this is hard to explain so just see the commit message ok?
    $logmsg =~ s/([\x00-\x08\x0A-\x1F\x7F-\xFF]+)/sprintf "<<hex(%*v02X)>>","",$1/ge;
    print $log_fh "$ENV{GL_TS}\t$ENV{GL_USER}\t$ip\t$logmsg\n";
    close $log_fh or die "close log failed: $!\n";
}

# ln -sf :-)
sub ln_sf
{
    my($srcdir, $glob, $dstdir) = @_;
    for my $hook ( glob("$srcdir/$glob") ) {
        $hook =~ s/$srcdir\///;
        unlink                   "$dstdir/$hook";
        symlink "$srcdir/$hook", "$dstdir/$hook" or die "could not symlink $srcdir/$hook to $dstdir\n";
    }
}

# list physical repos
sub list_phy_repos
{
    my @phy_repos;

    wrap_chdir("$ENV{GL_REPO_BASE_ABS}");
    for my $repo (`find . -type d -name "*.git" -prune`) {
        chomp ($repo);
        $repo =~ s(\./(.*)\.git$)($1);
        push @phy_repos, $repo;
    }

    return @phy_repos;
}

# ----------------------------------------------------------------------------
#       serious logic subs (as opposed to just "convenience" subs)
# ----------------------------------------------------------------------------

# check one ref
sub check_ref {

    # normally, the $ref will be whatever ref the commit is trying to update
    # (like refs/heads/master or whatever).  At least one of the refexes that
    # pertain to this user must match this ref **and** the corresponding
    # permission must also match the action (W/+, or C/D if used) being
    # attempted.  If none of them match, the access is denied.

    # NOTE: the function DIES when access is denied, unless arg 5 is true

    my ($allowed_refs, $repo, $ref, $perm, $dry_run) = @_;
    my @allowed_refs = sort { $a->[0] <=> $b->[0] } @{$allowed_refs};
    for my $ar (@allowed_refs) {
        my $refex = $ar->[1];
        # refex?  sure -- a regex to match a ref against :)
        next unless $ref =~ /^$refex/;
        return "DENIED by $refex" if $ar->[2] eq '-' and $dry_run;
        die "$perm $ref $ENV{GL_USER} DENIED by $refex\n" if $ar->[2] eq '-';

        # as far as *this* ref is concerned we're ok
        return $refex if ($ar->[2] =~ /\Q$perm/);
    }
    return "DENIED by fallthru" if $dry_run;
    die "$perm $ref $repo $ENV{GL_USER} DENIED by fallthru\n";
}

# ----------------------------------------------------------------------------
#       create a new repository
# ----------------------------------------------------------------------------

# NOTE: this sub will change your cwd; caller beware!
sub new_repo
{
    my ($repo, $hooks_dir, $creator) = @_;

    umask($REPO_UMASK);
    die "wildrepos disabled, can't set creator $creator on new repo $repo\n"
        if $creator and not $GL_WILDREPOS;

    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 >&2");
    if ($creator) {
        system("echo $creator > gl-creater");
        system("git", "config", "gitweb.owner", $creator);
    }
    # propagate our own, plus any local admin-defined, hooks
    ln_sf($hooks_dir, "*", "hooks");
    # in case of package install, GL_ADMINDIR is no longer the top cop;
    # override with the package hooks
    ln_sf("$GL_PACKAGE_HOOKS/common", "*", "hooks") if $GL_PACKAGE_HOOKS;
    chmod 0755, "hooks/update";

    # run gitolite's post-init hook if you can.  GL_REPO will be correct on a
    # wildcard create but on a normal (config file) create it will actually be
    # set to "gitolite-admin", so we need to make sure that for the duration
    # of the hook it is set correctly.
    system("env GL_REPO='$repo' hooks/gl-post-init") if -x "hooks/gl-post-init";
}

sub new_wild_repo {
    my ($repo, $user) = @_;

    wrap_chdir("$ENV{GL_REPO_BASE_ABS}");
    new_repo($repo, "$GL_ADMINDIR/hooks/common", $user);
        # note pwd is now the bare "repo.git"; new_repo does that...
    wrap_print("gl-perms", "$GL_WILDREPOS_DEFPERMS\n") if $GL_WILDREPOS_DEFPERMS;
    setup_git_configs($repo, \%git_configs);
    setup_daemon_access($repo);
    add_del_line ("$repo.git", $PROJECTS_LIST, setup_gitweb_access($repo, '', ''));
    wrap_chdir($ENV{HOME});
}

# ----------------------------------------------------------------------------
#       wild_repo_rights
# ----------------------------------------------------------------------------

{
    # the following subs need some persistent data, so we make a closure
    my $cache_filled = 0;
    my %cached_groups;
    sub fill_cache {
        # pull in basic group info
        unless ($cache_filled) {
            local(%repos, %groups);
            local $^W = 0;
            # read group info from compiled config.  At the time we're called
            # this info has not yet been pulled in by the rest of the code, so
            # we need to do this specially here.  However, the info we're
            # looking for is not subject to variable substitutions so we don't
            # really care; we just pull it in once and save it for the rest of
            # the run
            do $GL_CONF_COMPILED;
            %cached_groups = %groups;
            $cache_filled++;
        }
    }

    # "who created this repo", "am I on the R list", and "am I on the RW list"?
    sub wild_repo_rights
    {
        # set default categories
        $GL_WILDREPOS_PERM_CATS ||= "READERS WRITERS";
        my ($repo, $user) = @_;

        # creator
        my $c = '';
        if (                     -f "$ENV{GL_REPO_BASE_ABS}/$repo.git/gl-creater") {
            my $fh = wrap_open("<", "$ENV{GL_REPO_BASE_ABS}/$repo.git/gl-creater");
            chomp($c = <$fh>);
        }

        # now get the permission categories (used to be just R and RW.  Now
        # there can be any others that the admin defines in the RC file via
        # $GL_WILDREPOS_PERM_CATS variable (space separated list)

        # For instance, if the user is "foo", and gl-perms has "R bar", "RW
        # foo baz", and "TESTERS frob @all", this hash will then contain
        # "WRITERS=>foo" and "TESTERS=>@all"
        my %perm_cats;

        if ($user and            -f "$ENV{GL_REPO_BASE_ABS}/$repo.git/gl-perms") {
            my $fh = wrap_open("<", "$ENV{GL_REPO_BASE_ABS}/$repo.git/gl-perms");
            my $perms = join ("", <$fh>);
            # discard comments
            $perms =~ s/#.*//g;
            # convert R and RW to the actual category names in the config file
            $perms =~ s/^\s*R /READERS /mg;
            $perms =~ s/^\s*RW /WRITERS /mg;
            # $perms is say "READERS alice @foo @bar\nRW bob @baz" (the entire gl-perms
            # file).  We replace each @foo with $user if $cached_groups{'@foo'}{$user}
            # exists (i.e., $user is a member of @foo)
            for my $g ($perms =~ /\s(\@\S+)/g) {
                fill_cache();   # get %cached_groups
                $perms =~ s/ $g(?!\S)/ $user/ if $cached_groups{$g}{$user};
            }
            # now setup the perm_cats hash to be returned
            if ($perms) {
                # let's say our user is "foo".  gl-perms has "CAT bar @all",
                # you add CAT => @all to the hash.  similarly, if gl-perms has
                # "DOG bar foo baz", you add DOG => foo to the hash.  And
                # since specific perms must override @all, we do @all first.
                $perm_cats{$1} = '@all' while ($perms =~ /^[ \t]*(\S+)(?=[ \t]).*[ \t]\@all([ \t]|$)/mg);
                $perm_cats{$1} = $user  while ($perms =~ /^[ \t]*(\S+)(?=[ \t]).*[ \t]$user([ \t]|$)/mg);
                # validate the categories being sent back
                for (sort keys %perm_cats) {
                    die "invalid permission category $_\n" unless $GL_WILDREPOS_PERM_CATS =~ /(^|\s)$_(\s|$)/;
                }
            }
        }

        return ($c, %perm_cats);
    }
}

# ----------------------------------------------------------------------------
#       getperms and setperms
# ----------------------------------------------------------------------------

sub get_set_perms
{
    my($repo, $verb, $user) = @_;
    # set default categories
    $GL_WILDREPOS_PERM_CATS ||= "READERS WRITERS";
    my ($creator, $dummy, $dummy2) = wild_repo_rights($repo, "");
    die "$repo doesnt exist or is not yours\n" unless $user eq $creator;
    wrap_chdir("$ENV{GL_REPO_BASE_ABS}");
    wrap_chdir("$repo.git");
    if ($verb eq 'getperms') {
        return unless -f "gl-perms";
        my $perms = `cat gl-perms`;
        # convert R and RW to the actual category names in the config file
        $perms =~ s/^\s*R /READERS /mg;
        $perms =~ s/^\s*RW /WRITERS /mg;
        print $perms;
    } else {
        system("cat > gl-perms");
        my $perms = `cat gl-perms`;
        # convert R and RW to the actual category names in the config file
        $perms =~ s/^\s*R /READERS /mg;
        $perms =~ s/^\s*RW /WRITERS /mg;
        for my $g ($perms =~ /^\s*(\S+)/g) {
            die "invalid permission category $g\n" unless $GL_WILDREPOS_PERM_CATS =~ /(^|\s)$g(\s|$)/;
        }
        print "New perms are:\n";
        print $perms;

        # gitweb and daemon
        setup_daemon_access($repo);
        # add or delete line (arg1) from file (arg2) depending on arg3
        add_del_line ("$repo.git", $PROJECTS_LIST, setup_gitweb_access($repo, '', ''));
    }
}

# ----------------------------------------------------------------------------
#       getdesc and setdesc
# ----------------------------------------------------------------------------

sub get_set_desc
{
    my($repo, $verb, $user) = @_;
    my ($creator, $dummy, $dummy2) = wild_repo_rights($repo, "");
    die "$repo doesnt exist or is not yours\n" unless $user eq $creator;
    wrap_chdir("$ENV{GL_REPO_BASE_ABS}");
    wrap_chdir("$repo.git");
    if ($verb eq 'getdesc') {
        system("cat", "description") if -f "description";
    } else {
        system("cat > description");
        print "New description is:\n";
        system("cat", "description");
    }
}

# ----------------------------------------------------------------------------
#       IMPORTANT NOTE: next 3 subs (setup_*) assume $PWD is the bare repo itself
# ----------------------------------------------------------------------------

# ----------------------------------------------------------------------------
#       set/unset git configs
# ----------------------------------------------------------------------------

sub setup_git_configs
{
    my ($repo, $git_configs_p) = @_;

    while ( my ($key, $value) = each(%{ $git_configs_p->{$repo} }) ) {
        if ($value ne "") {
            $value =~ s/^"(.*)"$/$1/;
            system("git", "config", $key, $value);
        } else {
            system("git", "config", "--unset-all", $key);
        }
    }
}

# ----------------------------------------------------------------------------
#       set/unset daemon access
# ----------------------------------------------------------------------------

# does not return anything; just touch/unlink the appropriate file
my $export_ok = "git-daemon-export-ok";
sub setup_daemon_access
{
    my $repo = shift;

    if (can_read($repo, 'daemon')) {
        wrap_print($export_ok, "");
    } else {
        unlink($export_ok);
    }
}

# ----------------------------------------------------------------------------
#       set/unset gitweb access
# ----------------------------------------------------------------------------

# returns 1 if gitweb access has happened; this is to allow the caller to add
# an entry to the projects.list file
my $desc_file = "description";
sub setup_gitweb_access
# this also sets "owner" for gitweb, by the way
{
    my ($repo, $desc, $owner) = @_;
    my $is_wild = -f "gl-creater";
        # we may override but we do not remove gitweb.owner and description
        # for wild repos

    if ($desc) {
        open(DESC, ">", $desc_file);
        print DESC $desc . "\n";
        close DESC;
    } else {
        unlink $desc_file unless $is_wild;
    }

    if ($owner) {
        system("git", "config", "gitweb.owner", $owner);
    } else {
        system("git config --unset-all gitweb.owner 2>/dev/null") unless $is_wild;
    }

    # if there are no gitweb.* keys set, remove the section to keep the config file clean
    my $keys = `git config --get-regexp '^gitweb\\.' 2>/dev/null`;
    if (length($keys) == 0) {
        system("git config --remove-section gitweb 2>/dev/null");
    }

    return ($desc or can_read($repo, 'gitweb'));
        # this return value is used by the caller to write to projects.list
}

# ----------------------------------------------------------------------------
#       print a report of $user's basic permissions
# ----------------------------------------------------------------------------

sub report_version {
    my($user) = @_;
    print "hello $user, the gitolite version here is ";
    system("cat", ($GL_PACKAGE_CONF || "$GL_ADMINDIR/conf") . "/VERSION");
}

sub perm_code {
    # print the permission code
    my($all, $super, $user, $x) = @_;
    return "    " unless $all or $super or $user;
    return "  $x " unless $all or $super;   # only $user (explicit access) was given
    my $ret;
    $ret = " \@$x" if $all;                 # prefix @ if repo allows access for @all users
    $ret = " \#$x" if $super;               # prefix # if user has access to @all repos (sort of like a super user)
    $ret = " \&$x" if $all and $super;      # prefix & if both the above
    $ret .= ($user ? " " : "_" );           # suffix _ if no explicit access else <space>
    return $ret;
}

# basic means wildcards will be shown as wildcards; this is pretty much what
# got parsed by the compile script
sub report_basic
{
    my($repo, $user) = @_;

    # XXX The correct way is actually to give parse_acl another argument
    # (defaulting to $ENV{GL_USER}, the value being used now).  But for now
    # this will do, even though it's a bit of a kludge to get the basic access
    # rights for some other user this way
    local $ENV{GL_USER} = $user;

    parse_acl("", "CREATOR");
    # all we need is for 'keys %repos' to come up with all the names, so:
    @repos{ keys %split_conf } = values %split_conf if %split_conf;

    # send back some useful info if no command was given
    report_version($user);
    print "\rthe gitolite config gives you the following access:\r\n";
    my $count = 0;
    for my $r (sort keys %repos) {
        next unless $r =~ /$repo/i;
        # if $GL_BIG_CONFIG is on, limit the number of output lines to 20
        next if $GL_BIG_CONFIG and $count++ >= 20;
        if ($r =~ $REPONAME_PATT and $r !~ /\bCREAT[EO]R\b/) {
            parse_acl($r, "NOBODY");
        } else {
            $r =~ s/\bCREAT[EO]R\b/$user/g;
            parse_acl($r, $ENV{GL_USER});
        }
        # @all repos; meaning of read/write flags:
        # @R => @all users are allowed access to this repo
        # #R => you're a super user and can see @all repos
        #  R => normal access
        my $perm .= ( $repos{$r}{C}{'@all'} ? ' @C' :                                      ( $repos{$r}{C}{$user} ? '  C' : '   ' ) );
        $perm .= perm_code( $repos{$r}{R}{'@all'}, $repos{'@all'}{R}{$user}, $repos{$r}{R}{$user}, 'R');
        $perm .= perm_code( $repos{$r}{W}{'@all'}, $repos{'@all'}{W}{$user}, $repos{$r}{W}{$user}, 'W');
        print "$perm\t$r\r\n" if $perm =~ /\S/;
    }
    print "only 20 out of $count candidate repos examined\r\nplease use a partial reponame or regex pattern to limit output\r\n" if $GL_BIG_CONFIG and $count > 20;
    print "$GL_SITE_INFO\n" if $GL_SITE_INFO;
}

# ----------------------------------------------------------------------------
#       print a report of $user's expanded permissions
# ----------------------------------------------------------------------------

sub expand_wild
{
    my($repo, $user) = @_;

    report_version($user);
    print "\ryou have access to the following repos on the server:\r\n";
    # this is for convenience; he can copy-paste the output of the basic
    # access report instead of having to manually change CREATOR to his name
    $repo =~ s/\bCREAT[EO]R\b/$user/g;

    # display matching repos (from *all* the repos in the system) that $user
    # has at least "R" access to

    chdir("$ENV{GL_REPO_BASE_ABS}") or die "chdir $ENV{GL_REPO_BASE_ABS} failed: $!\n";
    my $count = 0;
    for my $actual_repo (`find . -type d -name "*.git" -prune|sort`) {
        chomp ($actual_repo);
        $actual_repo =~ s/^\.\///;
        $actual_repo =~ s/\.git$//;
        # actual_repo has to match the pattern being expanded
        next unless $actual_repo =~ /$repo/i;
        next if $GL_BIG_CONFIG and $count++ >= 20;

        my($perm, $creator, $wild) = repo_rights($actual_repo);
        next unless $perm =~ /\S/;
        print "$perm\t$creator\t$actual_repo\n";
    }
    print "only 20 out of $count candidate repos examined\nplease use a partial reponame or regex pattern to limit output\n" if $GL_BIG_CONFIG and $count > 20;
    print "$GL_SITE_INFO\n" if $GL_SITE_INFO;
}

# ----------------------------------------------------------------------------
#       parse the compiled acl
# ----------------------------------------------------------------------------

sub parse_acl
{
    # IMPLEMENTATION NOTE: a wee bit of this is duplicated in the update hook;
    # please update that also if the interface or the env vars change

    my ($repo, $c, %perm_cats) = @_;
    my $perm_cats_sig = '';     # a "signature" of the perm_cats hash
    map { $perm_cats_sig .= "$_.$perm_cats{$_}," } sort keys %perm_cats;
    $c = "NOBODY" unless $GL_WILDREPOS;

    # set up the variables for a parse to interpolate stuff from the dumped
    # hash (remember the selective conversion of single to double quotes?).

    # if they're not passed in, then we look for an env var of that name, else
    # we default to "NOBODY" (we hope there isn't a real user called NOBODY!)
    # And in any case, we set those env vars so level 2 can redo the last
    # parse without any special code

    our $creator = $ENV{GL_CREATOR} = $c || $ENV{GL_CREATOR} || "NOBODY";
    our $gl_user = $ENV{GL_USER};

    # these need to persist across calls to this function, so "our"
    our $saved_crwu;
    our (%saved_repos, %saved_groups);

    if ($saved_crwu and $saved_crwu eq "$creator,$perm_cats_sig,$gl_user") {
        %repos = %saved_repos; %groups = %saved_groups;
    } else {
        die "parse $GL_CONF_COMPILED failed: " . ($! or $@) unless do $GL_CONF_COMPILED;
    }
    unless (defined($data_version) and $data_version eq $current_data_version) {
        # this cannot happen for 'easy-install' cases, by the way...
        print STDERR "(INTERNAL: $data_version -> $current_data_version; running gl-setup)\n";
        system("$ENV{SHELL} -l -c gl-setup >&2");

        die "parse $GL_CONF_COMPILED failed: " . ($! or $@) unless do $GL_CONF_COMPILED;
    }
    $saved_crwu = "$creator,$perm_cats_sig,$gl_user";
    %saved_repos = %repos; %saved_groups = %groups;
    add_repo_conf($repo) if $repo;

    # basic access reporting doesn't send $repo, and doesn't need to; you just
    # want the config dumped as is, really
    return unless $repo;

    my ($wild, @repo_plus, @user_plus);
    # expand $repo and $gl_user into all possible matching values
    ($wild, @repo_plus) = get_memberships($repo,    1);
    (       @user_plus) = get_memberships($gl_user, 0);

    # the old "convenience copy" thing.  Now on steroids :)

    # note that when copying the @all entry, we retain the destination name as
    # @all; we dont change it to $repo or $gl_user
    for my $r ('@all', @repo_plus) {
        my $dr = $repo; $dr = '@all' if $r eq '@all';
        $repos{$dr}{DELETE_IS_D} = 1 if $repos{$r}{DELETE_IS_D};
        $repos{$dr}{CREATE_IS_C} = 1 if $repos{$r}{CREATE_IS_C};
        $repos{$dr}{NAME_LIMITS} = 1 if $repos{$r}{NAME_LIMITS};
        $git_configs{$dr} = $git_configs{$r} if $git_configs{$r};

        for my $u ('@all', "$gl_user - wild", @user_plus, keys %perm_cats) {
            my $du = $gl_user; $du = '@all' if $u eq '@all' or ($perm_cats{$u} || '') eq '@all';
            $repos{$dr}{C}{$du} = 1 if $repos{$r}{C}{$u};
            $repos{$dr}{R}{$du} = 1 if $repos{$r}{R}{$u};
            $repos{$dr}{W}{$du} = 1 if $repos{$r}{W}{$u};

            next if $r eq $dr and $u eq $du;    # no point duplicating those refexes
            push @{ $repos{$dr}{$du} }, @{ $repos{$r}{$u} }
                if exists $repos{$r}{$u} and ref($repos{$r}{$u}) eq 'ARRAY';
        }
    }

    return ($wild);
}

# add repo conf from repo.git/gl-conf
sub add_repo_conf
{
    my ($repo) = shift;
    return unless $split_conf{$repo};
    do "$ENV{GL_REPO_BASE_ABS}/$repo.git/gl-conf" or return;
    $repos{$repo} = $one_repo{$repo};
    $git_configs{$repo} = $one_git_config{$repo};
}

# ----------------------------------------------------------------------------
#       repo_rights
# ----------------------------------------------------------------------------

# there will be multiple calls to repo_rights; better to use a closure.  We
# might even be called from outside (see the admin-defined-commands docs for
# how/why).  Regardless of how we're called, we assume $ENV{GL_USER} is
# already defined
{
    my $last_repo = '';
    sub repo_rights {
        my $repo = shift;
        $repo =~ s/^\.\///;
        $repo =~ s/\.git$//;

        # we get passed an actual repo name.  It may be a normal
        # (non-wildcard) repo, in which case it is assumed to exist.  If it's
        # a wildrepo, it may or may not exist.  If it doesn't exist, the "C"
        # perms are also filled in, else that column is left blank

        unless ($REPO_BASE) {
            # means we've been called from outside; see doc/admin-defined-commands.mkd
            where_is_rc();
            die "parse $ENV{GL_RC} failed: "       . ($! or $@) unless do $ENV{GL_RC};
        }

        my $perm = '   ';
        my $creator;

        # get basic info about the repo and fill %repos
        my $wild = '';
        my $exists = -d "$ENV{GL_REPO_BASE_ABS}/$repo.git";
        if ($exists) {
            # the list of permission categories within gl-perms that this user is a member
            # of, or that specify @all as a member.  See comments in
            # "wild_repo_rights" sub for nuances.
            my (%perm_cats);
            # these will be empty if it's not a wildcard repo anyway
            ($creator, %perm_cats) = wild_repo_rights($repo, $ENV{GL_USER});
            # get access list with these substitutions
            $wild = parse_acl($repo, $creator || "NOBODY", %perm_cats);
        } else {
            $wild = parse_acl($repo, $ENV{GL_USER});
        }

        if ($exists) {
            if ($creator and $wild) {
                $creator = "($creator)";
            } elsif ($creator and not $wild) {
                # was created wild but then someone (a) removed the pattern
                # from, and (b) added the actual reponame to, the config
                $creator = "<was_$creator>"
            } else {
                $creator = "<gitolite>";
            }
        } else {
            # repo didn't exist; C perms need to be filled in
            $perm = ( $repos{$repo}{C}{'@all'} ? ' @C' : ( $repos{$repo}{C}{$ENV{GL_USER}} ? ' =C' : '   ' )) if $GL_WILDREPOS;
            # if you didn't have perms to create it, delete the "convenience"
            # copy of the ACL that parse_acl makes
            delete $repos{$repo} if $perm !~ /C/ and $wild;
            $creator = "<notfound>";
        }
        $perm .= perm_code( $repos{$repo}{R}{'@all'}, $repos{'@all'}{R}{$ENV{GL_USER}}, $repos{$repo}{R}{$ENV{GL_USER}}, 'R' );
        $perm .= perm_code( $repos{$repo}{W}{'@all'}, $repos{'@all'}{W}{$ENV{GL_USER}}, $repos{$repo}{W}{$ENV{GL_USER}}, 'W' );

        # set up for caching %repos
        $last_repo = $repo;

        return($perm, $creator, $wild);
    }
}

# ----------------------------------------------------------------------------
#       helpers...
# ----------------------------------------------------------------------------

# helper/convenience routine to get rights and ownership from a shell command
sub cli_repo_rights {
    # check_access does a lot more, so just call it.  Since it returns perms
    # and creator separately, just space-join them and print it.
    print join(" ", check_access($_[0])), "\n";
}

sub can_read {
    my $repo = shift;
    my $user = shift || $ENV{GL_USER};
    local $ENV{GL_USER} = $user;
    my ($perm, $creator, $wild) = repo_rights($repo);
    return ( ($GL_ALL_INCLUDES_SPECIAL || $user !~ /^(gitweb|daemon)$/)
        ? $perm =~ /R/
        : $perm =~ /R /
    );
}

# helper to manage "disabling" a repo or the whole site for "W" access
sub check_repo_write_enabled {
    my ($repo) = shift;
    for my $d ("$ENV{HOME}/.gitolite.down", "$ENV{GL_REPO_BASE_ABS}/$repo.git/.gitolite.down") {
        next unless -f $d;
        die $ABRT . `cat $d` if -s $d;
        die $ABRT . "writes are currently disabled\n";
    }
}

# ----------------------------------------------------------------------------
#       get memberships
# ----------------------------------------------------------------------------

# given a plain reponame or username, return:
# - the name itself if it's a user
# - the name itself if it's a repo and the repo exists in the config
# plus, if $GL_BIG_CONFIG is set:
# - all the groups the name belongs to
# plus, for repos:
# - all the wildcards matching it
# plus, if $GL_BIG_CONFIG is set:
# - all the groups those wildcards belong to

# A name can normally appear (repo example) (user example)
# - directly (repo foo) (RW = bob)
# - (only for repos) as a direct wildcard (repo foo/.*)
# but if $GL_BIG_CONFIG is set, it can also appear:
# - indirectly (@g = foo; repo @g) (@ug = bob; RW = @ug))
# - (only for repos) as an indirect wildcard (@g = foo/.*; repo @g).
# note: the wildcard stuff does not apply to username memberships

our %extgroups_cache;
sub get_memberships {
    my $base = shift;   # reponame or username
    my $is_repo = shift;    # some true value means a repo name has been passed

    my $wild = '';      # will be a space-sep list of matching patterns
    my @ret;            # list of matching groups/patterns

    # direct
    push @ret, $base if not $is_repo or exists $repos{$base};
    if ($is_repo and $GL_WILDREPOS) {
        for my $i (sort keys %repos) {
            next if $i eq $base;    # "direct" name already done; skip
            # direct wildcard
            if ($base =~ /^$i$/) {
                push @ret, $i;
                $wild = ($wild ? "$wild $i" : $i);
            }
        }
    }

    if ($GL_BIG_CONFIG) {
        for my $g (sort keys %groups) {
            for my $i (sort keys %{ $groups{$g} }) {
                if ($base eq $i) {
                    # indirect
                    push @ret, $g;
                } elsif ($is_repo and $GL_WILDREPOS and $base =~ /^$i$/) {
                    # indirect wildcard
                    push @ret, $g;
                    $wild = ($wild ? "$wild $i" : $i);
                }
            }
        }
    }

    # deal with returning user info first
    unless ($is_repo) {
        # bring in group membership info stored externally, by running
        # $GL_GET_MEMBERSHIPS_PGM if it is defined

        if ($extgroups_cache{$base}) {
            push @ret, @{ $extgroups_cache{$base} };
        } elsif ($GL_GET_MEMBERSHIPS_PGM) {
            my @extgroups = map { s/^/@/; $_; } split ' ', `$GL_GET_MEMBERSHIPS_PGM $base`;
            $extgroups_cache{$base} = \@extgroups;
            push @ret, @extgroups;
        }

        return (@ret);
    }

    # note that there is an extra return value when called for repos (as
    # opposed to being called for usernames)
    return ($wild, @ret);
}

# ----------------------------------------------------------------------------
#       generic check access routine
# ----------------------------------------------------------------------------

sub check_access
{
    my ($repo, $ref, $aa, $dry_run) = @_;
    # aa = attempted access

    my ($perm, $creator, $wild) = repo_rights($repo);
    $perm =~ s/ /_/g;
    $creator =~ s/^\(|\)$//g;
    return ($perm, $creator) unless $ref;

    # until I do some major refactoring (which will bloat the update hook a
    # bit, sadly), this code duplicates stuff in the current update hook.

    my @allowed_refs;
    # user+repo specific perms override everything else, so they come first.
    # Then perms given to specific user for @all repos, and finally perms
    # given to @all users for specific repo
    push @allowed_refs, @ { $repos{$repo}{$ENV{GL_USER}} || [] };
    push @allowed_refs, @ { $repos{'@all'}{$ENV{GL_USER}} || [] };
    push @allowed_refs, @ { $repos{$repo}{'@all'} || [] };

    if ($dry_run) {
        return check_ref(\@allowed_refs, $repo, $ref, $aa, $dry_run);
    } else {
        check_ref(\@allowed_refs, $repo, $ref, $aa);
    }
}

# ----------------------------------------------------------------------------
#       setup the ~/.ssh/authorized_keys file
# ----------------------------------------------------------------------------

sub setup_authkeys
{
    # ARGUMENTS

    my($GL_KEYDIR, $user_list_p) = @_;
    # calling from outside the normal compile script may mean that argument 2
    # may not be passed; so make sure it's a valid hashref, even if empty
    $user_list_p = {} unless $user_list_p;

    # LOCAL CONSTANTS

    # command and options for authorized_keys
    my $AUTH_COMMAND="$ENV{GL_BINDIR}/gl-auth-command";
    $AUTH_COMMAND="$ENV{GL_BINDIR}/gl-time $ENV{GL_BINDIR}/gl-auth-command" if $GL_PERFLOGT;
    my $AUTH_OPTIONS="no-port-forwarding,no-X11-forwarding,no-agent-forwarding,no-pty";

    # START

    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);
    my @not_in_config;  # pubkeys exist but users don't appear in the config file
    for my $pubkey (`find . -type f | sort`)
    {
        chomp($pubkey); $pubkey =~ s(^\./)();

        # security check (thanks to divVerent for catching this)
        unless ($pubkey =~ $REPONAME_PATT) {
            print STDERR "$pubkey contains some unsavoury characters; ignored...\n";
            next;
        }

        # lint check 1
        unless ($pubkey =~ /\.pub$/)
        {
            print STDERR "WARNING: pubkey files should end with \".pub\", ignoring $pubkey\n";
            next;
        }

        my $user = $pubkey;
        $user =~ s(.*/)();                  # foo/bar/baz.pub -> baz.pub
        $user =~ s/(\@[^.]+)?\.pub$//;      # baz.pub, baz@home.pub -> baz

        # lint check 2 -- don't print right now; just collect the messages
        push @not_in_config, "$user($pubkey)" if %$user_list_p and not $user_list_p->{$user};
        $user_list_p->{$user} = 'has pubkey'  if %$user_list_p;
        # apparently some pubkeys don't end in a newline...
        my $pubkey_content;
        {
            local $/ = undef;
            local @ARGV = ($pubkey);
            $pubkey_content = <>;
        }
        $pubkey_content =~ s/\s*$/\n/;
        # don't trust files with multiple lines (i.e., something after a newline)
        if ($pubkey_content =~ /\n./)
        {
            print STDERR "WARNING: a pubkey file can only have one line (key); ignoring $pubkey\n" .
                         "         If you want to add multiple public keys for a single user, use\n" .
                         "         \"user\@host.pub\" file names.  See the \"one user, many keys\"\n" .
                         "         section in doc/3-faq-tips-etc.mkd for details.\n";
            next;
        }
        print $newkeys_fh "command=\"$AUTH_COMMAND $user\",$AUTH_OPTIONS ";
        print $newkeys_fh $pubkey_content;
    }

    # lint check 2 -- print less noisily
    if (@not_in_config > 10) {
        print STDERR "$WARN You have " . scalar(@not_in_config) . " pubkeys that do not appear to be used in the config\n";
    } elsif (@not_in_config) {
        print STDERR "$WARN the following users (pubkey files in parens) do not appear in the config file:\n", join(",", sort @not_in_config), "\n";
    }

    # lint check 3; a little more severe than the first two I guess...
    {
        my @no_pubkey =
            grep { $_ !~ /^(gitweb|daemon|\@.*|~\$creator)$/ }
                grep { $user_list_p->{$_} ne 'has pubkey' }
                    grep { $GL_WILDREPOS_PERM_CATS !~ /(^|\s)$_(\s|$)/ }
                        keys %{$user_list_p};
        if (@no_pubkey > 10) {
            print STDERR "$WARN You have " . scalar(@no_pubkey) . " users WITHOUT pubkeys...!\n";
        } elsif (@no_pubkey) {
            print STDERR "$WARN the following users have no pubkeys:\n", join(",", sort @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")
        and die "couldn't write authkeys file\n";
    system("rm  $ENV{HOME}/.ssh/new_authkeys");
}

# ----------------------------------------------------------------------------
#       S P E C I A L   C O M M A N D S
# ----------------------------------------------------------------------------

sub special_cmd
{
    my ($shell_allowed) = @_;

    my $cmd = $ENV{SSH_ORIGINAL_COMMAND};
    my $user = $ENV{GL_USER};

    # check each special command we know about and call it if enabled
    if ($cmd eq 'info') {
        report_basic('^', $user);
        print "you also have shell access\r\n" if $shell_allowed;
    } elsif ($cmd =~ /^info\s+(.+)$/) {
        my @otherusers = split ' ', $1;
        # the first argument is assumed to be a repo pattern, like in the
        # expand command
        my $repo = shift(@otherusers);
        die "$repo has invalid characters" unless "x$repo" =~ $REPOPATT_PATT;
        print STDERR "(treating $repo as pattern to limit output)\n";

        # set up the list of users being queried; it's either a list passed in
        # (allowed only for admin pushers) or just $user
        if (@otherusers) {
            my($perm, $creator, $wild) = repo_rights('gitolite-admin');
            die "you can't ask for others' permissions\n" unless $perm =~ /W/;
        }
        push @otherusers, $user unless @otherusers;

        parse_acl();
        for my $otheruser (@otherusers) {
            warn("ignoring illegal username $otheruser\n"), next unless $otheruser =~ $USERNAME_PATT;
            report_basic($repo, $otheruser);
        }
    } elsif ($HTPASSWD_FILE and $cmd eq 'htpasswd') {
        ext_cmd_htpasswd($HTPASSWD_FILE);
    } elsif ($RSYNC_BASE and $cmd =~ /^rsync /) {
        ext_cmd_rsync($GL_CONF_COMPILED, $RSYNC_BASE, $cmd);
    } elsif ($SVNSERVE and $cmd eq 'svnserve -t') {
        ext_cmd_svnserve($SVNSERVE);
    } else {
        # if the user is allowed a shell, just run the command
        log_it();
        exec $ENV{SHELL}, "-c", $cmd if $shell_allowed;

        die "bad command: $cmd\n";
    }
}

sub run_custom_command {
    my $user = shift;

    my $cmd = $ENV{SSH_ORIGINAL_COMMAND};
    my ($verb, $repo) = ($cmd =~ /^\s*(\S+)(?:\s+'?\/?(.*?)(?:\.git)?'?)?$/);
    # deal with "no argument" cases
    $verb eq 'expand' ? $repo = '^' : die "$verb needs an argument\n" unless $repo;
    if ($repo =~ $REPONAME_PATT and $verb =~ /getperms|setperms/) {
        # with an actual reponame, you can "getperms" or "setperms"
        get_set_perms($repo, $verb, $user);
    }
    elsif ($repo =~ $REPONAME_PATT and $verb =~ /(get|set)desc/) {
        # with an actual reponame, you can "getdesc" or "setdesc"
        get_set_desc($repo, $verb, $user);
    }
    elsif ($verb eq 'expand') {
        # with a wildcard, you can "expand" it to see what repos actually match
        die "$repo has invalid characters" unless "x$repo" =~ $REPOPATT_PATT;
        expand_wild($repo, $user);
    } else {
        die "$cmd doesn't make sense to me\n";
    }
}

sub shell_out {
    my $shell = $ENV{SHELL};
    $shell =~ s/.*\//-/;    # change "/bin/bash" to "-bash"
    log_it($shell);
    exec { $ENV{SHELL} } $shell;
}

sub try_adc {
    my ($cmd, @args) = split ' ', $ENV{SSH_ORIGINAL_COMMAND};
    if (-x "$GL_ADC_PATH/$cmd") {
        die "I don't like $cmd\n" if $cmd =~ /\.\./;
        # yes this is rather strict, sorry.
        do { die "I don't like $_\n" unless $_ =~ $ADC_CMD_ARGS_PATT } for ($cmd, @args);
        log_it("$GL_ADC_PATH/$ENV{SSH_ORIGINAL_COMMAND}");
        exec("$GL_ADC_PATH/$cmd", @args);
    }
}

# ----------------------------------------------------------------------------
#       external command helper: rsync
# ----------------------------------------------------------------------------

sub ext_cmd_rsync
{
    my ($GL_CONF_COMPILED, $RSYNC_BASE, $cmd) = @_;

    # test the command patterns; reject if they don't fit.  Rsync sends
    # commands that looks like one of these to the server (the first one is
    # for a read, the second for a write)
    #   rsync --server --sender -some.flags . some/path
    #   rsync --server -some.flags . some/path

    die "bad rsync command: $cmd"
        unless $cmd =~ /^rsync --server( --sender)? -[\w.]+(?: --(?:delete|partial))* \. (\S+)$/;
    my $perm = "W";
    $perm = "R" if $1;
    my $path = $2;
    die "I dont like some of the characters in $path\n" unless $path =~ $REPONAME_PATT;
        # XXX make a better pattern for this if people complain ;-)
    die "I dont like absolute paths in $cmd\n" if $path =~ /^\//;
    die "I dont like '..' paths in $cmd\n" if $path =~ /\.\./;

    # ok now check if we're permitted to execute a $perm action on $path
    # (taken as a refex) using rsync.

    check_access('EXTCMD/rsync', "NAME/$path", $perm);
        # that should "die" if there's a problem

    wrap_chdir($RSYNC_BASE);
    log_it();
    exec $ENV{SHELL}, "-c", $ENV{SSH_ORIGINAL_COMMAND};
}

# ----------------------------------------------------------------------------
#       external command helper: htpasswd
# ----------------------------------------------------------------------------

sub ext_cmd_htpasswd
{
    my $HTPASSWD_FILE = shift;

    die "$HTPASSWD_FILE doesn't exist or is not writable\n" unless -w $HTPASSWD_FILE;
    $|++;
    print <<EOFhtp;
Please type in your new htpasswd at the prompt.  You only have to type it once.

NOTE THAT THE PASSWORD WILL BE ECHOED, so please make sure no one is
shoulder-surfing, and make sure you clear your screen as well as scrollback
history after you're done (or close your terminal instance).

EOFhtp
    print "new htpasswd:";

    my $password = <>;
    $password =~ s/[\n\r]*$//;
    die "empty passwords are not allowed\n" unless $password;
    my $rc = system("htpasswd", "-b", $HTPASSWD_FILE, $ENV{GL_USER}, $password);
    die "htpasswd command seems to have failed with $rc return code...\n" if $rc;
}

# ----------------------------------------------------------------------------
#       external command helper: svnserve
# ----------------------------------------------------------------------------

sub ext_cmd_svnserve
{
    my $SVNSERVE = shift;

    $SVNSERVE =~ s/%u/$ENV{GL_USER}/g;
    exec $SVNSERVE;
    die "svnserve exec failed\n";
}

# ------------------------------------------------------------------------------
# per perl rules, this should be the last line in such a file:
1;