#!/usr/bin/perl

use strict;
use warnings;
use 5.010;
use File::Spec;
use Getopt::Long;
use Git;
use GitLab::API::v4::Constants 0.11 qw( :all );
use GitLab::API::v4 0.13;
use JSON;
use Pod::Usage qw( pod2usage );
use Try::Tiny;
use utf8::all;
use Term::ANSIColor;

# honour CLICOLOR; NO_COLOR is automatically honoured
if ( exists( $ENV{CLICOLOR} ) && $ENV{CLICOLOR} == 0 ) {
    if ( !$ENV{CLICOLOR_FORCE} ) {
        $ENV{ANSI_COLORS_DISABLED} = 1;
    }
}
# also disable colors if STDOUT is not a tty
$ENV{ANSI_COLORS_DISABLED} = 1 unless -t STDOUT;

# config
## defaults
my %config = (
    api_url                         => 'https://salsa.debian.org/api/v4',
    private_token                   => '',
    perl_team_path                  => 'perl-team',
    perl_team_id                    => 2663,
    perl_team_interpreter_path      => 'perl-team/interpreter',
    perl_team_interpreter_id        => 2664,
    perl_team_modules_path          => 'perl-team/modules',
    perl_team_modules_id            => 2665,
    perl_team_modules_packages_path => 'perl-team/modules/packages',
    perl_team_modules_packages_id   => 2666,
    perl_team_modules_attic_path    => 'perl-team/modules/attic',
    perl_team_modules_attic_id      => 2667,
    perl_team_modules_meta_path     => 'perl-team/modules/meta',
    perl_team_modules_meta_id       => 13881,
    perl_team_pages_path            => 'perl-team/perl-team.pages.debian.net',
    perl_team_pages_id              => 13873,
    perl_team_scripts_path          => 'perl-team/scripts',
    perl_team_scripts_id            => 13429,
    packages                        => '',
);

## update from environment / config file
## this is also exported by dpt(1) from ~/.dpt.conf / ~/.config/dpt.conf
## use DPT_SALSA_FOO as $config{foo}
foreach ( keys %config ) {
    my $KEY = 'DPT_SALSA_' . uc($_);
    $config{$_} = $ENV{$KEY} if $ENV{$KEY};
}
## also read DPT_PACKAGES
$config{packages} = $ENV{DPT_PACKAGES};

# commandline
## options
my %opts;
GetOptions(
    \%opts,         'help|?', 'man', 'json',
    'all',          'attic',  'on',  'off',
    'parallel|j=i', 'verbose',
) or pod2usage(2);
pod2usage(1) if $opts{help};
pod2usage( -exitval => 0, -verbose => 2 ) if $opts{man};
pod2usage(    # don't check earlier to allow for --help/--man
    -msg      => "E: DPT_SALSA_PRIVATE_TOKEN not set.\n",
    -exitval  => 2,
    -verbose  => 99,
    -sections => "SYNOPSIS|CONFIGURATION",
) unless $config{private_token};

my $jobs = $opts{parallel} || 1;
$jobs = 0 unless $jobs =~ /^\d{1,3}$/ and $jobs > 1;

## subcommand and arguments
my $command = shift @ARGV;
pod2usage("E: No subcommand given.\n") unless $command;
my @args = @ARGV;

# our API object
my $api = GitLab::API::v4->new(
    url           => $config{api_url},
    private_token => $config{private_token},
);

# data
my %levels_name = (
    no_access  => $GITLAB_ACCESS_LEVEL_NO_ACCESS,
    guest      => $GITLAB_ACCESS_LEVEL_GUEST,
    reporter   => $GITLAB_ACCESS_LEVEL_REPORTER,
    developer  => $GITLAB_ACCESS_LEVEL_DEVELOPER,
    maintainer => $GITLAB_ACCESS_LEVEL_MASTER,
    owner      => $GITLAB_ACCESS_LEVEL_OWNER,
);

my %levels_code = (
    $GITLAB_ACCESS_LEVEL_NO_ACCESS => 'no access',
    $GITLAB_ACCESS_LEVEL_GUEST     => 'guest',
    $GITLAB_ACCESS_LEVEL_REPORTER  => 'reporter',
    $GITLAB_ACCESS_LEVEL_DEVELOPER => 'developer',
    $GITLAB_ACCESS_LEVEL_MASTER    => 'maintainer',
    $GITLAB_ACCESS_LEVEL_OWNER     => 'owner',
);

# run command
if ( $command eq 'version' ) {
    version();
} elsif ( $command eq 'current_user' ) {
    current_user();
} elsif ( $command eq 'adduser' ) {
    adduser();
} elsif ( $command eq 'removeuser'
    or $command eq 'rmuser'
    or $command eq 'deluser' )
{
    removeuser();
} elsif ( $command eq 'changeuser' ) {
    changeuser();
} elsif ( $command eq 'listmembers'
    or $command eq 'listmember'
    or $command eq 'lsmembers'
    or $command eq 'lsmember'
    or $command eq 'listusers'
    or $command eq 'listuser'
    or $command eq 'lsusers'
    or $command eq 'lsuser' )
{
    listmembers();
} elsif ( $command eq 'listrepos'
    or $command eq 'lsrepos'
    or $command eq 'listrepo'
    or $command eq 'lsrepo' )
{
    listrepos();
} elsif ( $command eq 'createrepo' ) {
    createrepo();
} elsif ( $command eq 'pushrepo' ) {
    pushrepo();
} elsif ( $command eq 'configurerepo' ) {
    configurerepo();
} elsif ( $command eq 'changerepo' ) {
    changerepo();
} elsif ( $command eq 'deleterepo' ) {
    deleterepo();
} elsif ( $command eq 'kgb' ) {
    kgb();
} elsif ( $command eq 'mrconfig' ) {
    mrconfig();
} elsif ( $command eq 'toattic' ) {
    toattic();
} elsif ( $command eq 'fromattic' ) {
    fromattic();
} elsif ( $command eq 'help' ) {
    pod2usage(1);
} else {
    pod2usage("E: Unknown subcommand: $command.\n");
}
exit;

# subcommand implementations
## version()
sub version {
    my $version = $api->version();
    if ( $opts{json} ) {
        say prettyjson($version);
    } else {
        say "Version:  " . $version->{version};
        say "Revision: " . $version->{revision};
    }
}

## current_user()
sub current_user {
    my $current_user = $api->current_user();
    if ( $opts{json} ) {
        say prettyjson($current_user);
    } else {
        say "Username: " . $current_user->{username};
        say "Name:     " . $current_user->{name};
        say "Email:    " . $current_user->{email};
    }
}

## adduser()
sub adduser {
    my ( $user, $level ) = @args;
    die 'Required parameter username|userid missing.' unless $user;
    $level ||= 'maintainer';

    my $user_id = user2userid($user);

    my $access_level = $levels_name{ lc($level) };
    die "Unknown access level '$level'." unless $access_level;

    $api->add_group_member( $config{perl_team_modules_id},
        { user_id => $user_id, access_level => $access_level } );
}

## changeuser()
sub changeuser {
    my ( $level, $user ) = @args;
    die 'Required parameter "access level" missing.' unless $level;
    die 'Required parameter username|userid missing.'
        unless ( $user or $opts{all} );
    my @userids = $opts{all} ? listmembers() : $user;

    foreach (@userids) {
        my $user_id = user2userid($_);

        my $access_level = $levels_name{ lc($level) };
        die "Unknown access level '$level'." unless $access_level;

        $api->update_group_member(
            $config{perl_team_modules_id},
            $user_id, { access_level => $access_level },
        );
    }
}

## removeuser()
sub removeuser {
    my ($user) = @args;
    die 'Required parameter username|userid missing.' unless $user;
    my $user_id = user2userid($user);
    $api->remove_group_member( $config{perl_team_modules_id}, $user_id );
}

## listmembers()
sub listmembers {
    my $paginator
        = $api->paginator( 'group_members', $config{perl_team_modules_id} );
    my @userids;
    while ( my $user = trypaginator($paginator) ) {
        push @userids, $user->{id};
        next if $opts{all};
        if ( $opts{json} ) {
            say prettyjson($user);
        } else {
            my $access_level = $levels_code{ $user->{access_level} };
            say "Id:           " . $user->{id};
            say "Username:     " . $user->{username};
            say "Name:         " . $user->{name};
            say "Access level: " . $access_level;
        }
    }
    return @userids;
}

## listrepos()
sub listrepos {
    my $paginator = $api->paginator(
        'group_projects',
        $opts{attic}
        ? $config{perl_team_modules_attic_id}
        : $config{perl_team_modules_packages_id},
        { order_by => 'name', sort => 'asc', simple => $opts{all}, }
    );
    my @repoids;
    while ( my $repo = trypaginator($paginator) ) {
        push @repoids, $repo->{id};
        next if $opts{all};
        if ( $opts{json} ) {
            say prettyjson($repo);
        } else {
            say "Id:   " . $repo->{id};
            say "Name: " . $repo->{name};
            say "URL:  " . $repo->{web_url};
        }
    }
    return @repoids;
}

## createrepo()
sub createrepo {
    my ($reponame) = shift || @args;
    die 'Required parameter repositoryname missing.' unless $reponame;

    my $repo = $api->create_project(
        {   name         => $reponame,
            namespace_id => $config{perl_team_modules_packages_id},
            visibility   => 'public',
        }
    );
    configurerepo( $repo->{id} );
}

## pushrepo()
sub pushrepo {
    my $pkg = qx/dh_testdir && dpkg-parsechangelog --show-field Source/;
    die "Can't find the name of this source package." unless $pkg;
    chomp $pkg;

    my $localrepo = Git->repository();
    my %remotes = map { my ( $name, $url ) = split ' '; $name => $url; }
        $localrepo->command( 'remote', '--verbose', 'show' );
    my $salsaurl
        = 'git@salsa.debian.org:'
        . $config{perl_team_modules_packages_path}
        . "/$pkg.git";
    if ( !$remotes{'origin'} ) {
        $localrepo->command( 'remote', 'add', 'origin', $salsaurl );
    } elsif ( $remotes{'origin'}
        !~ m!^git\@salsa\.debian\.org:$config{perl_team_modules_packages_path}/$pkg\.git$!
        )
    {
        $localrepo->command( 'remote', 'set-url', 'origin', $salsaurl );
    }

    createrepo($pkg)
        unless $api->project(
        $config{perl_team_modules_packages_path} . '/' . $pkg );

    # or --mirror instead of the two? also pushes origin/ branches
    $localrepo->command( 'push', '--all', '--verbose', '--set-upstream',
        'origin' );
    $localrepo->command( 'push', '--tags', '--verbose', 'origin' );
}

## configurerepo()
sub configurerepo {
    my ($repo) = shift || @args;
    die 'Required parameter reponame|repoid missing.'
        unless ( $repo or $opts{all} );
    my @repoids = $opts{all} ? listrepos() : $repo;

    my %failures;
    my $access_level = get_access_level();

    # parallel
    my $pm;
    if ($jobs) {
        eval {
            require Parallel::ForkManager;
            $pm = Parallel::ForkManager->new($jobs);
        }
            or warn "Parallel::ForkManager not found. "
            . " apt install libparallel-forkmanager-perl ?\n"
            . "Continuing in a single process.\n";
    }

    foreach (@repoids) {
        my $repo_name = $_; # set to id for error message when getting the name fails

        if ($pm) {
            $pm->start and next;
        }

        try {
            my $repo_path = repo2repopath($_);
            $repo_name = $api->project($repo_path)->{name};

            # basic settings
            my $configparams = {
                description  => "Debian package $repo_name",
                wiki_enabled => 0,
                tag_list => ['dpt-salsa-configured'],
            };
            # changing visibility needs owner permissions
            $configparams->{visibility} = 'public'
                if defined $access_level
                && $access_level >= $GITLAB_ACCESS_LEVEL_OWNER;
            $api->edit_project( $repo_path, $configparams );

            # webhooks: cleanup and set: tagpending and kgb
            my $hooks = $api->project_hooks($repo_path);
            $api->delete_project_hook( $repo_path, $_->{id} ) foreach @{$hooks};

            $api->create_project_hook(
                $repo_path,
                {   url =>
                        "https://webhook.salsa.debian.org/tagpending/$repo_name",
                    push_events => 1,
                }
            );
            $api->create_project_hook(
                $repo_path,
                {   url =>
                        'https://kgb.debian.net/webhook/?channel=debian-perl-changes&pipeline_only_status=success&pipeline_only_status=failed',
                    push_events                  => 1,
                    # push_events_branch_filter  => 'string',
                    issues_events                => 1,
                    confidential_issues_events   => 0,
                    merge_requests_events        => 1,
                    tag_push_events              => 1,
                    note_events                  => 1,
                    confidential_notes_events    => 0, # or _comments_? not exposed by Gitlab::API::v4 or Gitlab API yet
                    job_events                   => 0,
                    pipeline_events              => 1,
                    wiki_page_events             => 1,
                }
            );
            say colored( "I: repository '$repo_name' configured.", 'green' )
                if $opts{verbose};
        }
        catch {
            say STDERR colored(
                "W: repository '$repo_name' configuration failed: '$_'.",
                'yellow' )
                if $opts{verbose};
            $failures{$repo_name} = $_;
        }
        finally {
            $pm->finish() if $pm;
        };
    }

    $pm->wait_all_children if $pm;

    say STDERR colored( "E: configurerepo() failed for $_: " . $failures{$_},
        'red' )
        foreach sort keys %failures;
}

## kgb()
sub kgb {
    my ($repo) = shift || @args;
    die 'Required parameter reponame|repoid missing.'
        unless ( $repo or $opts{all} );
    my @repoids = $opts{all} ? listrepos() : $repo;

    ( $opts{on} xor $opts{off} )
        or die "Exactly on of --on or --off is required";

    foreach (@repoids) {
        my $repo_path = repo2repopath($_);
        my $repo_name = $api->project($repo_path)->{name};

        my $hooks = $api->project_hooks($repo_path);

        if ($opts{off}) {
            foreach ( @{$hooks} ) {
                $api->delete_project_hook( $repo_path, $_->{id} )
                    if $_->{url} =~ m{^https?://kgb\.debian\.net(?::\d+)?/};
            }
        }

        if ( $opts{on} ) {
            my $already_present;

            foreach ( @{$hooks} ) {
                $already_present = 1, last
                    if $_->{url} =~ m{^https://kgb\.debian\.net/};

                # remove legacy hooks
                $api->delete_project_hook( $repo_path, $_->{id} )
                    if $_->{url} =~ m{^https?://kgb\.debian\.net(?::\d+)?/};
            }

            unless ($already_present) {
                $api->create_project_hook(
                    $repo_path,
                    {   url =>
                            'https://kgb.debian.net/webhook/?channel=debian-perl-changes&pipeline_only_status=success&pipeline_only_status=failed',
                        push_events                  => 1,
                        # push_events_branch_filter  => 'string',
                        issues_events                => 1,
                        confidential_issues_events   => 0,
                        merge_requests_events        => 1,
                        tag_push_events              => 1,
                        note_events                  => 1,
                        confidential_notes_events    => 0, # or _comments_? not exposed by Gitlab::API::v4 or Gitlab API yet
                        job_events                   => 0,
                        pipeline_events              => 1,
                        wiki_page_events             => 1,
                    }
                );
            }
        }
    }
}

## changerepo()
sub changerepo {
    my ( $repo, $property, $value ) = @args;
    die 'Required parameter reponame|repoid missing.'  unless $repo;
    die 'Required parameter name|description missing.' unless $property;
    die "Unknown property '$property'. Valid cases: 'name' or 'description'."
        unless ( $property eq 'name' or $property eq 'description' );
    die 'Required parameter "new value" missing.' unless $value;

    my $repo_path = repo2repopath($repo);
    $api->edit_project( $repo_path, { $property => $value } );
    $api->edit_project( $repo_path, { path      => $value } )
        if $property eq 'name';
}

## deleterepo()
sub deleterepo {
    my ($repo) = shift || @args;
    die 'Required parameter reponame|repoid missing.' unless $repo;

    my $access_level = get_access_level();
    die 'Deleting a project needs owner privileges.'
        unless defined $access_level
        && $access_level >= $GITLAB_ACCESS_LEVEL_OWNER;

    my $repo_path = repo2repopath($repo);
    $api->delete_project($repo_path);
}

## mrconfig()
sub mrconfig {
    die 'DPT_PACKAGES not set.' unless $config{packages};

    # mrconfig
    my $mroutdir = File::Spec->catdir( $config{packages}, '..' );
    die "Can't find directory '$mroutdir'." unless -d $mroutdir;

    my $mrconfig = File::Spec->catfile( $mroutdir, '.mrconfig' );
    die "Can't find '.mrconfig' in '$mroutdir'" unless -f $mrconfig;

    my $mroutfile = File::Spec->catfile( $mroutdir, '.mrconfig.packages' );
    open( my $mrfh, '>', "$mroutfile.new" )
        or die "Can't open '$mroutfile.new': $!";
    my @mrstanzas;

    # lastactivity
    my $lastactivityoutdir
        = File::Spec->catdir( $config{packages}, '..', '.lastactivity' );
    -d $lastactivityoutdir
        or mkdir($lastactivityoutdir)
        or die "Can't find or create directory '$lastactivityoutdir': $!";

    my @currentlastactivityfiles = glob("$lastactivityoutdir/*");
    s{$lastactivityoutdir/}{}o for @currentlastactivityfiles;
    my %currentlastactivityfiles
        = map( ( $_ => 1 ), @currentlastactivityfiles );

    # parallel
    my $pm;
    if ($jobs) {
        eval {
            require Parallel::ForkManager;
            $pm = Parallel::ForkManager->new($jobs);
            $pm->run_on_finish(
                sub {
                    my ( $pid, $exit_code, $ident, $exit_signal, $core_dump,
                        $data_structure_reference )
                        = @_;
                    push @mrstanzas, ${$data_structure_reference}
                        if defined($data_structure_reference);
                }
            );
        }
            or warn "Parallel::ForkManager not found. "
            . " apt install libparallel-forkmanager-perl ?\n"
            . "Continuing in a single process.\n";
    }

    my $paginator = $api->paginator(
        'group_projects',
        $config{perl_team_modules_packages_id},
        { order_by => 'name', sort => 'asc', simple => 1, }
    );
    my @misconfigrepos;
    my @dirtyrepos;
    my $num_repos = 0;
    while ( my $repo = trypaginator($paginator) ) {
        my $reponame = $repo->{name};
        delete $currentlastactivityfiles{$reponame};
        my $tag_list = $repo->{tag_list};
        push @misconfigrepos, $reponame
            unless grep( /dpt-salsa-configured/, @{$tag_list} );
        push @dirtyrepos, $reponame if repoisdirty($reponame);

        if ($pm) {
            # progress indicator
            print STDERR colored( '.', 'green' ) unless $num_repos++ % 50;

            $pm->start and next;
        }

        # mrconfig
        my $mrstanza
            = "[packages/$reponame]\ncheckout = git_checkout $reponame\n\n";
        # without Parallel::ForkManager or $jobs=0, output directly
        # with Parallel::ForkManager, return $mrstanza at the end
        if ( !$pm ) {
            ## stdout
            say $mrstanza;
            ## file
            say $mrfh $mrstanza;
        }

        # lastactivity
        my $lastactivityoutfile
            = File::Spec->catfile( $lastactivityoutdir, $reponame );
        my $lastactivity = $repo->{last_activity_at};
        if ($lastactivity) {
            open( my $lastactivityfh, '>', "$lastactivityoutfile.new" )
                or die "Can't open '$lastactivityoutfile.new': $!";
            print $lastactivityfh $lastactivity;
            close $lastactivityfh;
            rename "$lastactivityoutfile.new", "$lastactivityoutfile"
                or die
                "Can't rename '$lastactivityoutfile.new' to '$lastactivityoutfile': $!";
        } else {
            if ( -f "$lastactivityoutfile" ) {
                unlink "$lastactivityoutfile"
                    or die "Can't delete stale '$lastactivityoutfile': $!";
            }
        }

        $pm->finish( 0, \$mrstanza ) if $pm;
    }

    $pm->wait_all_children if $pm;

    print STDERR "\n" if $pm; # end progress indicator output

    # mrconfig
    # parallel case
    if ($pm) {
        ## stdout
        say @mrstanzas;
        ## file
        say $mrfh @mrstanzas;
    }
    close $mrfh;
    rename "$mroutfile.new", "$mroutfile"
        or die "Can't rename '$mroutfile.new' to '$mroutfile': $!";

    # lastactivity
    unlink "$lastactivityoutdir/$_" for keys %currentlastactivityfiles;

    # potentially misconfigured repos
    if (scalar @misconfigrepos) {
        say STDERR colored( "W: Potentially misconfigured perl-team repos:",
            'yellow' );
        say STDERR colored( "W: " . join( " ", @misconfigrepos ),
            'yellow' );
        say STDERR colored( "W: Maybe run 'dpt salsa configurerepo' on them.",
            'yellow' ), "\n";
    }

    # dirty repos
    if (scalar @dirtyrepos) {
        say STDERR colored( "W: Dirty repos:",
            'yellow' );
        say STDERR colored( "W: " . join( " ", @dirtyrepos ),
            'yellow' );
        say STDERR colored( "W: Please fix, 'gbp pull' will fail.",
            'yellow' ), "\n";
    }
}

## toattic()
sub toattic {
    my ($repo) = shift || @args;
    die 'Required parameter reponame|repoid missing.' unless $repo;
    my $repo_path = repo2repopath($repo);
    $api->transfer_project_to_namespace( $repo_path,
        { namespace => $config{perl_team_modules_attic_id} } );
}

## fromattic()
sub fromattic {
    my ($repo) = shift || @args;
    die 'Required parameter reponame|repoid missing.' unless $repo;
    my $repo_path = repo2repopath($repo);
    $api->transfer_project_to_namespace( $repo_path,
        { namespace => $config{perl_team_modules_packages_id} } );
    configurerepo($repo);
}

# helper functions
## prettyjson($data)
sub prettyjson {
    my $data = shift;
    my $json = JSON->new->utf8->pretty->canonical->allow_nonref();
    $json->encode($data);
}

## username2userid($username)
sub username2userid {
    my $username = shift;
    my $users = $api->users( { username => $username } );
    die "More than one user with username '$username'."
        if scalar @{$users} > 1;
    die "Username '$username' not found." if scalar @{$users} < 1;
    return $users->[0]->{id};
}

## user2userid($string)
sub user2userid {
    my $user = shift;
    return $user if $user =~ /^\d+$/;
    return username2userid($user) if $user =~ /^[\w-]+$/;
    die "Parameter '$user' doesn't look like a userid or a username.";
}

## get_access_level
sub get_access_level {
    my $user_id = $api->current_user()->{id};
    # group_member() is undef for non-members who still have access via groups (DDs)
    my $access_level;
    my $group_membership
        = $api->group_member( $config{perl_team_modules_path}, $user_id );
    $access_level = $group_membership->{access_level}
        if defined $group_membership;
}

## reponame2repoid($reponame)
## XXX unused
sub reponame2repoid {
    my $reponame = shift;
    my $repos = $api->projects( { search => $reponame } );
    die "More than one repository with name '$reponame'."
        if scalar @{$repos} > 1;
    die "Repository name '$reponame' not found." if scalar @{$repos} < 1;
    return $repos->[0]->{id};
}

## repo2repoid($string)
## XXX unused
sub repo2repoid {
    my $repo = shift;
    return $repo if $repo =~ /^\d+$/;
    return reponame2repoid($repo) if $repo =~ /^\w+$/;
    die
        "Parameter '$repo' doesn't look like a repositoryid or a repositoryname.";
}

## reponame2repopath($reponame)
sub reponame2repopath {
    my $reponame = shift;
    my $repopath_packages
        = $config{perl_team_modules_packages_path} . '/' . $reponame;
    my $repopath_attic
        = $config{perl_team_modules_attic_path} . '/' . $reponame;
    my $repo
        = $api->project($repopath_packages) || $api->project($repopath_attic);
    die
        "Repository name '$reponame' not found in '$config{perl_team_modules_packages_path}' or '$config{perl_team_modules_attic_path}'."
        unless $repo;
    return $repo->{path_with_namespace};
}

## repo2repopath($string)
sub repo2repopath {
    my $repo = shift;
    return $repo if $repo =~ /^\d+$/;
    return reponame2repopath($repo) if $repo =~ /^[\w-]+$/;
    die
        "Parameter '$repo' doesn't look like a repositoryid or a repositoryname.";
}

## repoisdirty
sub repoisdirty {
    my $reponame = shift;
    my $repodir  = File::Spec->catdir( $config{packages}, $reponame );
    return 0 unless -d $repodir; # don't bail out for not-yet-cloned repos
    my $repo = Git->repository($repodir);
    die "Can't create repo object from '$reponame': $!\n" unless $repo;

    # inspired by https://metacpan.org/dist/Git-Repository-Plugin-Dirty/source/lib/Git/Repository/Plugin/Dirty.pm
    # note: `gbp pull' doesn't directly fail on staged/unpushed changes but the merge might
    # question: best order of staged/unstaged/untracked? untracked is more expensive but is staged or unstaged more common?
    eval { $repo->command_oneline( 'diff', '--quiet', '--cached' ) };
    my $staged = $?;
    return 1 if $staged;

    eval { $repo->command_oneline( 'diff', '--quiet' ) };
    my $unstaged = $?;
    return 1 if $unstaged;

    my @untracked
        = grep {m/^\?\? /}
        $repo->command( 'status', '--untracked-files', '--short', '--porcelain' );
    return 1 if scalar @untracked;

    # else
    return 0;
}

## trypaginator($paginator)
sub trypaginator {
    my $paginator = shift;
    my $trials    = 1;
    my $record;
    use constant MAXTRIALS => 5;
    while ( !defined $record && $trials <= MAXTRIALS ) {
        $record = try {
            $paginator->next();
        }
        catch {
            STDERR->autoflush(1);
            say STDERR colored( "W: Error at try $trials: $_", 'yellow' );
            if ( $trials < MAXTRIALS ) {
                my $delay = $trials * 2;
                print STDERR colored( "W: Retrying in $delay seconds ",
                    'yellow' );
                do { print STDERR '.'; sleep 1; } while --$delay;
                print STDERR "\n";
            } else {
                say STDERR colored( "E: Giving up.", 'red' );
            }
            undef;
        }
        finally {
            $trials++;
        }
    }
    return $record;
}

__END__

=head1 NAME

B<dpt-salsa> - manage repositories and members of the I<perl-team> on I<salsa.debian.org>

=head1 SYNOPSIS

B<dpt salsa> [--help|--man|--json|--verbose|--all|--attic] I<subcommand> [parameters]

=head1 DESCRIPTION

B<dpt-salsa> is basically a wrapper around L<GitLab::API::v4>, similar to
L<gitlab-api-v4(1)>, with various variables regarding I<salsa.debian.org>
and the I<modules> subgroup of the I<perl-team> group already preset and
typical method calls encapsulated.

It offers subcommands to manage repositories and members of the I<modules>
subgroup with hopefully less typing then calling the API manually each time.

Make sure to check the L</CONFIGURATION> section below if you use
B<dpt-salsa> for the first time.

=head1 SUBCOMMANDS

=head2 for managing repositories

=head3 I<pushrepo>

Creates a new repository in the I<modules> subgroup (with C<createrepo()> and
C<configurerepo()>) and pushes the local repository.

=head3 I<createrepo> I<repositoryname>

Creates a new empty repository in the I<modules> subgroup and calls C<configurerepo()>.

Parameters:

=over

=item repositoryname

Name of the repository to be added; usually the package name.
Required.

=back

=head3 I<configurerepo> I<repositoryid|repositoryname> [--verbose]

Sets up the default webhooks and services for one repository.

Parameters:

=over

=item repositoryid|repositoryname

The repository to be configured. Either its id (\d+) or name (\w+).
Required.

=back

Silent on success unless C<--verbose> is given.

=head3 I<configurerepo> I<--all> [--attic] [--verbose] [--parallel N] [-j N]

Sets up the default webhooks and services for all active (or, with
C<--attic>, archived) repositories.

Silent on success unless C<--verbose> is given.

With C<--parallel> L<Parallel::ForkManager> is employed for parallelism.

=head3 I<changerepo> I<repositoryid|repositoryname> I<"name"|"description"> C<"parameter">

Changes the name (and the path) or the description of a repository.

Parameters:

=over

=item repositoryid|repositoryname

The repository to be configured. Either its id (\d+) or name (\w+).
Required.

=item "name"|"description"

What should be changed? The "name" or the "description" of the repository.
Required.

=item parameter

The new name or description.
Required.

=back

=head3 I<deleterepo> I<repositoryid|repositoryname>

Delete a repository (a.k.a project).

Parameters:

=over

=item repositoryid|repositoryname

The repository to be deleted. Either its id (\d+) or name (\w+).
Required.

=back

=head3 I<listrepos> [--json] [--attic]

Show all active (or, with C<--attic>, archived) repositories in the
I<modules> subgroup.

If used with C<--all>, returns repository ids and does not output anything;
for internal use.

=head3 I<kgb> I<repositoryid|repositoryname>|I<--all> [--attic] I<--on|--off>

Install (C<--on>) or remove (C<--off>) the KGB IRC notification webhook
for the given, all active (C<--all>), or all
archived (C<--attic>) repositories.

C<--on> removes any legacy hooks (plain http, explicit port number) and
replaces them with the canonical one. If the repository already uses the right
hook, C<--on> does nothing.

Parameters:

=over

=item repositoryid|repositoryname

The repository to be configured. Either its id (\d+) or name (\w+).
Required unless C<--all> is used.

=back

=head3 I<toattic|fromattic> I<repositoryid|repositoryname>

Moves a repository to/from the I<attic> sub-group of the I<modules> sub-group.
Useful when a package is removed from the archive or added back.

Probably needs appropriate permissions.

=head2 for managing users

=head3 I<adduser> I<username|userid> [access_level]

Adds a user to the I<modules> subgroup of the I<perl-team> group.

Parameters:

=over

=item username|userid

The user to be added. Either their id (\d+) or their username (\w+).
Required.

=item access_level

One of I<GitLab>'s access levels: no_access, guest, reporter, developer, maintainer, owner.
Optional, defaults to C<maintainer>.

=back

=head3 I<removeuser> I<username|userid>

Removes a user from the I<modules> subgroup of the I<perl-team> group.

Parameters:

=over

=item username|userid

The user to be removed. Either their id (\d+) or their username (\w+).
Required.

=back

=head3 I<changeuser> I<access_level> I<username|userid>|I<--all>

Change the access level of one or all user(s) in the I<modules> subgroup of the
I<perl-team> group.

Parameters:

=over

=item access_level

One of I<GitLab>'s access levels: guest, reporter, developer, maintainer, owner.
Required.

=item username|userid

The user whose access level is to be changed. Either their id (\d+) or their
username (\w+).
Required, unless C<--all> is used.

=back

=head3 I<listmembers> [--json]

Show all members of the I<modules> subgroup of the I<perl-team> group.

If used with C<--all>, returns user ids and does not output anything; for
internal use.

=head2 others

=head3 I<mrconfig> [--parallel N] [-j N]

Helper for creating

=over

=item *

a F<.mrconfig.packages> file in the local clone of
C<meta.git> for all active packages of the I<modules> subgroup of the
I<perl-team> group. Also writes to stdout which can be included from
F<.mrconfig>.

=item *

F<.lastactivity/PKGNAME> files in the local clone of
C<meta.git> for all active packages of the I<modules> subgroup of the
I<perl-team> group which are then used by B<compare-lastactivity> in F<.mrconfig>.

=back

With C<--parallel> L<Parallel::ForkManager> is employed for parallelism.

Additionally, the option will also output a list of repositories
that potentially have not been configured with B<dpt-salsa>.

=head3 I<current_user> [--json]

Outputs information about the user whose I<GitLab> token is used.

=head3 I<help>

Same as option I<--help>.

=head3 I<version> [--json]

Returns the version of the I<GitLab> instance running on I<salsa.debian.org>.

This subcommand is pretty useless, the only excuse for its existence is the
ability to test if everything is working fine.

=head1 OPTIONS

=over

=item --help

Show short help.

=item --man

Show complete manpage.

=item --all

Act on all users or repositories, not a single named one.
Only for specific subcommands, as noted in their description.

=item --attic

Act on archived repositories instead of active ones.
Only for specific subcommands, as noted in their description.

=item --json

Format output as JSON instead of human-targeted text.
Only for specific subcommands, as noted in their description.

=item --verbose

Print output for otherwise silent and potentially long-running commands.
Only for specific subcommands, as noted in their description.

=back

=head1 CONFIGURATION

B<dpt-salsa> uses the following environment variables, set either directly
or via F<~/.dpt.conf> / F<~/.config/dpt.conf>:

=over

=item DPT_SALSA_PRIVATE_TOKEN

required, no default, obviously

These tokens are created at
L<https://salsa.debian.org/-/user_settings/personal_access_tokens>.
Note that the token needs B<api> and B<read_user> scope permissions.

=item DPT_SALSA_API_URL

optional, default: https://salsa.debian.org/api/v4

=item DPT_SALSA_PERL_TEAM_PATH

optional, default: perl-team

=item DPT_SALSA_PERL_TEAM_ID

optional, default: 2663

=item DPT_SALSA_PERL_TEAM_INTERPRETER_PATH

optional, default: perl-team/interpreter

=item DPT_SALSA_PERL_TEAM_INTERPRETER_ID

optional, default: 2664

=item DPT_SALSA_PERL_TEAM_MODULES_PATH

optional, default: perl-team/modules

=item DPT_SALSA_PERL_TEAM_MODULES_ID

optional, default: 2665

=item DPT_SALSA_PERL_TEAM_MODULES_PACKAGES_PATH

optional, default: perl-team/modules/packages

=item DPT_SALSA_PERL_TEAM_MODULES_PACKAGES_ID

optional, default: 2666

=item DPT_SALSA_PERL_TEAM_MODULES_ATTIC_PATH

optional, default: perl-team/modules/attic

=item DPT_SALSA_PERL_TEAM_MODULES_ATTIC_ID

optional, default: 2667

=item DPT_SALSA_PERL_TEAM_MODULES_META_PATH

optional, default: perl-team/modules/meta

=item DPT_SALSA_PERL_TEAM_MODULES_META_ID

optional, default: 13881

=item DPT_SALSA_PERL_TEAM_PAGES_PATH

optional, default: perl-team/perl-team.pages.debian.net

=item DPT_SALSA_PERL_TEAM_PAGES_ID

optional, default: 11266

=item DPT_SALSA_PERL_TEAM_SCRIPTS_PATH

optional, default: perl-team/scripts

=item DPT_SALSA_PERL_TEAM_SCRIPTS_ID

optional, default: 13429

=item DPT_PACKAGES

only used by the B<mrconfig> subcommand, no default;
most probably already set for use with other B<dpt> commands.

=back

Cf. L<dpt-config(5)>.

By default, the output of some subcommands uses colors, unless STDOUT is not
a tty or the environment variables CLICOLOR or NO_COLOR are set to false or
true, respectively.

=head1 SEE ALSO

L<https://salsa.debian.org/perl-team>

L<GitLab::API::v4>

L<https://docs.gitlab.com/ce/api/>

=head1 COPYRIGHT AND LICENSE

Copyright 2018-2025, gregor herrmann E<lt>gregoa@debian.orgE<gt>

Released under the same terms as Perl itself, i.e. Artistic or GPL-1+.