path: root/bin/locmaint

#!/usr/bin/perl

# Copyright (C) 2015-2020 Sean Whitton
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.



# This is meant to walk me through maintenance tasks that
# can't/shouldn't happen unattended by means of host configuration
# management and/or cron jobs installed by configuration management.
#
# That includes, at least:
#
# - checking in and backing up homedirs, which I need to do on all
#   machines, not just those for which I am root
#
# - apt upgrades of bare metal hosts (other than automatic security
#   upgrades)
#
# - cleaning up temporary files, old packages etc.
#
# - backups to storage usually kept offline
#
# Assumptions we make:
#
# - We rely on my myrepos-based homedir infrastructure.
#
# - Each offline backup drive I use has a unique filesystem label.
#   This means that exactly one drive will ever be mounted to
#   /media/$USER/$foo on a given machine.
#
# Other notes:
#
# - If this script dies, it should be possible to just run it again
#   from the beginning.  I.e. it should be idempotent.
#
# - This script should run with only core Perl modules.
#
#   Additionally functionality might be enabled when non-core modules
#   are available, but this functionality should only be needed on
#   hosts where I have root.

use strict;
use warnings;
use lib "$ENV{HOME}/src/dotfiles/perl5";
use constant {
    STABLE   => 'stable',
    TESTING  => 'testing',
    UNSTABLE => 'unstable',
};

use Array::Utils qw(array_minus);
use File::Basename;
use File::Find;
use File::Path qw(make_path);
use File::Spec::Functions qw(abs2rel rel2abs catfile);
use Getopt::Long;
use Local::Homedir;
use Local::Interactive qw(interactive_ensure_subroutine
                          interactive_ensure_subroutine_success
                          interactive_ensure_subroutine_no_output
                          system_pty_capture
                          prompt_Yn prompt_yn get_ack show_user
                        );
use Local::MrRepo;
use Local::ScriptStatus;
use Local::Util qw(as_root executable_find);
use Scalar::Util qw(looks_like_number);
use Sys::Hostname;

# whether we have root on this host
our $can_root = 0;

# whether we should expect to have an extdrive plugged in and
# referenced on the command line
our $check_for_extdrive = 0;

# CONFIG -- edit me

# List of remote annexes, offline backups of which should be paired
# and content-synced with repos in HOME, when those exist.  Repos on a
# remote server with a git-annex branch, which are not listed here,
# will be backed up as if they were just ordinary git repos.  That's
# desirable behaviour for some annexes, which is why we don't try to
# autodetect them.
#
# synconlyannex refers to the annex.synconlyannex config key; see
# git-annex-config(1).  We hardcode this here so that we can know how to clone
# an annex as part of backing it up even when there's no clone in HOME.
our @remote_annexes = (
    { origin => "athenag:annex.git",   homedir => "lib/annex", lazy => 1 },
    { origin => "athenag:annex19.git", homedir => "annex" },
    { origin => "athenag:libpriv.git", homedir => "lib/priv" },
    { origin => "athena:wikiannex",    homedir => "lib/wikiannex" },
    { origin => "athenap:athpriv",     homedir => "src/athpriv", synconlyannex => 1 });

for (getpwuid($<) . '@' . `hostname -f`) {
    chomp;

    # Code to set host-specific config based on "user@host.domain.tld"
    if (/^root@/ or /silentflame\.com$/) {
        $can_root = 1;
    }
    if (/@(zephyr|melete)\.silentflame\.com$/) {
        $check_for_extdrive = 1;
    }
}

# List of files which dpkg considers obsolete, but where deleting the
# conffile and reinstalling its package does not resolve the problem
# or is not what should be done.  One case in which doing that is not
# the correct fix is when conffiles move between packages.
#
# It's a bug in the package if
# - there are obsolete conffiles which the local administrator has
#   never modified
# - regardless of whether the file has been modified by the local
#   administrator, deleting the conffile and reinstalling its package
#   does not get clear the entry from the list of obsolete conffiles.
#
# When adding an entry to this list, see if a bug needs to be
# reported, and record the Debian release in which the bug was seen,
# so entries can be removed at some point
our %known_bad_obsolete_conffiles = (
    "/etc/this_is_a_sample_entry" => undef,    # buster
);

# CODE -- no more edit me

my $xdg_config_root = $ENV{XDG_CONFIG_HOME} || catfile $ENV{HOME}, ".config";

exit main();

sub main {
    # note that if Local::Interactive::system_pty_capture falls back
    # to calling script(1), this interrupt handler will not work, and
    # indeed C-c will not get us out of locmaint at all.  So let's
    # hope IO::Pty is available.
    $SIG{INT} = sub { print STDERR "\nlocmaint: interrupted\n"; exit 2 };

    # Parse command line.  If any of these get set to false, skip
    # those.  If any get set to true, do only those set to true.  If
    # none are set to true, do those which are left as 'undef'
    my $want_homedir;
    my $want_coldbkup;
    my $want_workstation_duplicity;
    my $want_sysmaint;
    my $want_skip_update;
    GetOptions('homedir|home!' => \$want_homedir,
               'coldbkup|cold!' => \$want_coldbkup,
               'workstation-duplicity|duplicity|duply!'
                 => \$want_workstation_duplicity,
               'sysmaint|sys!' => \$want_sysmaint,
               'skip-update|skip-up!' => \$want_skip_update)
      or die "failed to parse command line arguments";
    my $something_wanted = $want_homedir || $want_coldbkup
      || $want_workstation_duplicity || $want_sysmaint;
    my $do_homedir = $want_homedir // !$something_wanted;
    my $do_coldbkup = $want_coldbkup // !$something_wanted;
    my $do_workstation_duplicity =
      $want_workstation_duplicity // !$something_wanted;
    my $do_sysmaint = $want_sysmaint // !$something_wanted;
    my $skip_update = $want_skip_update // 0;

    my $coldbkup_root = shift @ARGV;
    unless (defined $coldbkup_root) {
        if ($want_coldbkup) {
            die "coldbkup requested but no dest provided on the command line";
        } elsif ($check_for_extdrive && $do_coldbkup) {
            say_bold
              ("You didn't specify a drive for coldbkup on the command line.");
            return 0 unless prompt_Yn("Continue locmaint without coldbkup?");
        }
        $do_coldbkup = 0;
    }

    do_homedir($skip_update) if $do_homedir;
    if ($do_coldbkup) {
        $coldbkup_root = rel2abs($coldbkup_root);
        do_coldbkup($coldbkup_root);

        # TODO make this work -- need to cause ssh control sockets
        # which have open file descriptors on the external drive to
        # exit (probably using `ssh -O exit`)
        # script_status("ejecting $coldbkup_root");
        # system "gio", "mount", "--eject", $coldbkup_root;
        # if ($?) {
        #     say_spaced_bullet("failed to eject $coldbkup_root!");
        #     get_ack();
        # }
    }
    do_workstation_duplicity() if $do_workstation_duplicity;
    do_sysmaint() if $do_sysmaint;

    # this is useful because we spawn so many interactive shells, and
    # the user might think the script hasn't finished but is waiting
    # on the user doing something
    print "\n";
    script_status("maintainance complete");

    return 0;
}

sub do_homedir {
    my ($skip_update) = @_;

    chdir;
    src_register_all();

    # Check places where temporary files are stored
    interactive_ensure_subroutine(
              sub { empty_dir_or_list("$ENV{HOME}/tmp") },
              sub { my $empty = shift;

                    say_spaced_bullet "There are files to be cleaned up."
                      unless $empty;
                    return $empty;
                },
              "$ENV{HOME}/tmp");

    # local/big: files not included in duplicity backups
    #
    # local/tmp: files I don't want to check into a repo, but small
    # enough to include in duplicity backups, but should not stick
    # around in ~/tmp.  and, git repos without an origin remote yet
    # (can't live in ~/src as src-register-all will complain)
    my $empty = 1;
    $empty = empty_dir_or_list($_) && $empty for qw(local/big local/tmp);
    unless ($empty) {
        say_spaced_bullet
          ("Consider cleaning up/annexing files in dir(s) listed above.");
        get_ack();
    }

    print "\n";
    show_user("ls --color=always --literal --classify ~",
              "Clean up any loose files in HOME.");

    my @mr_repos;
    push @mr_repos, Local::MrRepo::new_repo($_)
      foreach grep -d,
      map { /^mr list: (.+)$/; $1 // () } `mr ls`;

    # We try to update them all first, because this can take a while
    # so the machine can be left unattended.  We autoci first because
    # that increases the chance the update will succeed on its own
    unless ($skip_update) {
        # avoid git asking for creds on the terminal which will
        # typically happen when a git remote no longer exists
        # (e.g. because someone has deleted their fork).  Another
        # related trick is setting GIT_ASKPASS=/bin/true but that's a
        # larger hammer than doing this
        local $ENV{GIT_TERMINAL_PROMPT} = "0";

        script_status("trying to update all repos");
        foreach my $mr_repo (@mr_repos) {
            $mr_repo->auto_commit();
            $mr_repo->update();
        }
    }
    # Now the user-interactive walk through each repo
    foreach my $mr_repo (@mr_repos) {
        script_status("reviewing repo " . $mr_repo->toplevel);
        unless ($mr_repo->updated || $skip_update) {
            # see comment above for why we're setting this to 0 here
            local $ENV{GIT_TERMINAL_PROMPT} = "0";

            interactive_ensure_subroutine_success(sub { $mr_repo->update() },
                                                  $mr_repo->toplevel,
                                                  "try running `mr update'"
                                                 );
        }
        say_bold
          ("WARNING: status/review may not be accurate as update was skipped")
          if $skip_update;
        # If the repo supports reviewing, we hand off to that method,
        # requiring it to return a true value.  Otherwise, what we
        # require is empty status output.  We do not try to push on
        # the user's behalf, i.e., neither this script nor the
        # MrRepo::Repo classes directly execute `mr push`
        if ($mr_repo->can('review')) {
            interactive_ensure_subroutine(sub { $mr_repo->review() },
              sub { my $issues = shift;
                    say_spaced_bullet
                      ("There were issues when reviewing this repo.")
                      if $issues;
                    return !$issues; },
              $mr_repo->toplevel);
        } else {
            interactive_ensure_subroutine_no_output(sub { $mr_repo->status() },
                                                    $mr_repo->toplevel,
                                                    "`mr push' might be enough"
                                                   );
        }
    }

    # do this after in case reviewing the repos prompts me to save any
    # files this would delete
    src_cleanup();
    # look for any files outside of repos that src_cleanup() didn't
    # manage to clean up
    interactive_ensure_subroutine(\&loose_src_files, sub { return !shift },
                                  "$ENV{HOME}/src");
}

sub do_coldbkup {
    my $root = shift;

    return
      unless eval { require Git::Wrapper } and eval { require Net::GitHub };

    my $short = basename($root);
    my $gitbk = catfile($root, "gitbk");
    die "$root is not a directory" unless -d $root;
    die "$root is not a mount point" unless grep / on $root type /, `mount`;
    unless (-d $gitbk) {
        say_bold("Looks like you haven't backed up to this media before.");
        if (prompt_yn("Create a new backup repository at $gitbk?")) {
            mkdir $gitbk or die "unable to mkdir $gitbk -- check perms";
        } else {
            say_bold("Abandoning coldbkup ..");
            return;
        }
    }

    # clean up after old backup schemes
    mkdir catfile($gitbk, "old");
    mkdir catfile($gitbk, "old", "github");
    mkdir catfile($gitbk, "old", "salsa");
    rename $_, catfile($gitbk, "old", basename($_)) for glob "$gitbk/github_*";
    rename $_, catfile($gitbk, "old", "github", basename($_))
      for glob "$gitbk/github/*.git $gitbk/github/.*.git";
    rename $_, catfile($gitbk, "old", "salsa", basename($_))
      for glob "$gitbk/salsa/*.git";

    # starred repos on GitHub
    #
    # I used to use github-backup for this but the GitHub API rate
    # limiting seemed to mean that it was never able to complete the
    # backup, even after logging in with OAUTH.  See old propellor
    # config for that in ~/doc/howm/2017/old_propellor_config.org
    my $gh = Net::GitHub->new(version => 3);
    my $starred = $gh->query('/users/spwhitton/starred');
    foreach my $repo (@$starred) {
        my $org = $repo->{full_name} =~ s|/.+$||r;
        my $org_dir = catfile($gitbk, "github", $org);
	-d or mkdir for $org_dir;
        backup_repo($repo->{clone_url}, catfile($org_dir, $repo->{name}));

        # could run `github-backup --no-forks` in the repo at this
        # point, to grab metadata non-recursively
    }

    # athena main repos
    mkdir catfile($gitbk, "athena"); # compat dirname
    my @athena_repos = map {
        if (m|^/srv/git/repositories/priv/(.+)\.git$|) {
            { uri => "athenap:$1", dir => "priv/$1.git" }
        } elsif (m|^/srv/git/repositories/(.+)\.git$|) {
            { uri => "athena:$1", dir => "$1.git" }
        }
    } `ssh demeter find /srv/git/repositories -name "*.git" -type d 2>/dev/null`;
    backup_repo($_->{uri}, catfile($gitbk, "athena", $_->{dir}))
      for @athena_repos;

    # athena gcrypt repos
    mkdir catfile($gitbk, "athena_gcrypt");
    my @gcrypt_repos
      = map { m|^local/gcrypt/(.+)$|; { uri => "athenag:$1", dir => "$1" } }
      `ssh athena find local/gcrypt -name "*.git" -type d`;
    chomp @gcrypt_repos;
    backup_repo($_->{uri}, catfile($gitbk, "athena_gcrypt", $_->{dir}))
      for @gcrypt_repos;

    # check for old backups to be cleaned up
    my $old_coldbkups =
      find_old_coldbkups(catfile($gitbk, "athena"), \@athena_repos);
    $old_coldbkups =
      find_old_coldbkups(catfile($gitbk, "athena_gcrypt"), \@gcrypt_repos)
      || $old_coldbkups;
    if ($old_coldbkups) {
        say_spaced_bullet("Can remove if archived into annex.");
        get_ack();
    }

    # repos from Debian's salsa
    mkdir catfile($gitbk, "salsa");
    if (open my $fh,
        '<', catfile($ENV{HOME}, "doc", "conf", "coldbkup", "salsa")) {
        while (<$fh>) {
            m|^https://salsa\.debian\.org/(.+)$| or next;
            my $uri  = $&;
            my $dest = $1;
            $uri .= "/" if $uri =~ /\.git\z/;
            $uri .= ".git/" unless /\.git\/\z/;
            backup_repo($uri, catfile($gitbk, "salsa", $dest));
        }
    } else {
        say_bold(
            "WARNING: not backing up salsa repos: couldn't read list of repos"
        );
        get_ack();
    }

    # If I have other repos to back up at some point, could create
    # ~/doc/conf/otherrepos.csv which specifies URIs and dests (the
    # latter possibly abbreviated in some way)
}

sub do_workstation_duplicity {
    return unless eval { require Date::Manip };
    Date::Manip->import;

    my $profile = hostname() . "-" . getpwuid($<) . "-home";
    return unless -e "$ENV{HOME}/.duply/$profile/conf";

    # Offer to force a full backup if it has been five days since the
    # last.  When running locmaint I often have a good connection and
    # the time for that.  If I run locmaint often enough, the duply
    # cronjob can unconditionally do an incremental backup (which is
    # good for roaming between WiFi networks) but the backup chain
    # isn't in danger of growing too long
    my ($last_full) = grep /^Last full backup date: /m, `duply $profile status`;
    $last_full =~ s/^Last full backup date: //;

    my $full = ParseDate($last_full) lt ParseDate("5 days ago");

    # user can override and force incremental if time or bandwidth is
    # lacking
    $full = prompt_yn("Run full duply backup?  (requires time & bandwidth)")
      if $full;

    system "duply $profile " . ($full ? "full+purgeFull --force" : "incr");
}

sub do_sysmaint {
    return unless $can_root;
    executable_find "aptitude";

    # could also check uptime here, as old sysmaint did when run on
    # athena -- idea was that if uptime was unexpectedly low then I
    # needed to follow my documented post-reboot procedure

    # Make a guess as to whether we're on stable, testing or sid.
    # lsb_release(1) is an alternative to this, but that just performs
    # guesswork too, and it's not Essential, so we might as well do it
    # ourselves.
    #
    # This assumes that on a testing system, if we have a sid apt
    # source configured, it's in a file in /etc/apt/sources.list.d,
    # not in the file /etc/apt/sources.list
    #
    # Possibly /usr/lib/os-release is more portable.
    my $suite;
    open my $fh, '<', "/etc/debian_version"
      or die "failed to open /etc/debian_version for reading";
    chomp(my $debian_version = <$fh>);
    if (looks_like_number($debian_version)) {
        $suite = STABLE;
    } else {
        open my $fh, '<', "/etc/apt/sources.list"
          or die "failed to open /etc/apt/sources.list for reading";
        my $sources = do { local $/; <$fh> };
        if (grep / (sid|unstable) /, $sources) {
            $suite = UNSTABLE;
        } else {
            $suite = TESTING;
        }
    }

    chomp(my $kernel_release = `uname -r`);
    my $kernel_pkg_name = "linux-image-$kernel_release";

    my %purgeable;
    my @rc_packages;
    for (`dpkg -l`) {
        /^([a-zA-Z ][a-zA-Z ][a-zA-Z ])\s(\S+)\s/ or next;
        my ($stat, $pkg) = ($1, $2);
        if ($stat eq "rc ") {
            $purgeable{$pkg}{rc} = 1;
            # @rc_packages will be used before %purgeable is modified,
            # so we can its entries now.  @build_deps_packages and
            # @obsolete_packages will need be initialised only after
            # we've possibly removed some entries from %purgeable
            push @rc_packages, $pkg;
        }
        $purgeable{$pkg}{build_deps} = 1 if $pkg =~ /-build-deps\z/;
    }
    $purgeable{$_}{obsolete} = 1
      for grep !/\A$kernel_pkg_name\z/,
      map { /^..A? (\S+)\s/; $1 } `aptitude search '?obsolete'`;

    (split " ")[-1] =~ m#\A/(dev|run|snap|var/lib/schroot)#
      or print for `df -hP`;
    say_spaced_bullet(
	"Clean up some files if host does not have enough disc space");
    get_ack();

    script_status("updating apt indices");
    system as_root("apt-get update");
    die "apt-get update failed" unless $? == 0;
    unless (@rc_packages == 0) {
        say_bold("Conf-files packages:");
        print "  rc $_\n" for @rc_packages;
        if (prompt_yn("Purge these?")) {
            system as_root("apt-get -y purge @rc_packages");
            delete @purgeable{@rc_packages};
        }
    }
    my @build_deps_packages = grep { $purgeable{$_}{bd} } keys %purgeable;
    unless (@build_deps_packages == 0) {
        say_bold("mk-build-deps(1) packages:");
        print "  $_\n" for @build_deps_packages;
        if (prompt_yn("Purge these?")) {
            system as_root("apt-get -y purge @build_deps_packages");
            delete @purgeable{@build_deps_packages};
        }
    }

    # this is machine-specific, rather than being stored in this script,
    # because each time reinstall machine, the list should be reset
    my %local_pkgs;
    my $local_pkgs_file = catfile $xdg_config_root, qw(locmaint local_pkgs);
    if (-e $local_pkgs_file) {
	open my $local_pkgs_fh, "<", $local_pkgs_file;
	for (<$local_pkgs_fh>) {
	    chomp;
	    $local_pkgs{$_} = undef;
	}
    }

    my @obsolete_packages = grep !exists $local_pkgs{$_},
      grep $purgeable{$_}{obsolete}, keys %purgeable;
    # packages go in and out of testing frequently, so we probably
    # don't want to remove them
    unless (@obsolete_packages == 0 || $suite eq TESTING) {
        say_bold("Packages not available from any mirrors:");
        print "  $_\n" for @obsolete_packages;
        system as_root("apt-get -y purge @obsolete_packages")
          if prompt_yn("Purge these?");
    }
    # the first apt-get call is equivalent to `apt upgrade` (at the
    # time of writing) and has the advantage over plain `apt-get
    # upgrade` that new Recommends won't be missed, which is possible
    # with plain `apt-get upgrade`.  (Arguably plain `apt-get upgrade`
    # should never be used and its semantics were a poor design
    # choice.)
    script_status("doing apt upgrade");
    interactive_ensure_subroutine_success(
        sub { system_pty_capture(as_root("apt-get --with-new-pkgs upgrade")) }
    );
    interactive_ensure_subroutine_success(
        sub { system_pty_capture(as_root("apt-get dist-upgrade")) }
    );
    script_status("doing apt autoremove");
    interactive_ensure_subroutine_success(
        sub { system_pty_capture(as_root("apt-get -y autoremove")) }
    );
    script_status("autocleaning apt's cache");
    interactive_ensure_subroutine_success(
        sub { system_pty_capture(as_root("apt-get autoclean")) }
    );

    my $mailq = executable_find "mailq";
    if (-x $mailq and -x executable_find "dpkg-query") {
        `dpkg-query -S $mailq` =~ /: $mailq/;
	if ($` eq "postfix") {
	    interactive_ensure_subroutine(
		sub { system_pty_capture("mailq") },
		sub {
		    my $result = shift;
		    chomp($result->{output});
		    if ($result->{output} =~ /Mail queue is empty/) {
			return 1;
		    } else {
			say_bold("uh oh, expected an empty mail queue");
			return 0;
		    }
		});
	} elsif ($` eq "nullmailer") {
	    interactive_ensure_subroutine_no_output(
		sub { system_pty_capture("mailq") });
	}
    }

    my %obsolete_conffiles;
    my $curr_pkg;
    for (`dpkg-query --show --showformat='\${Package}\\n\${Conffiles}\\n'`) {
        chomp;
        /\S/ or next;
        if (/^\S/) {
            $curr_pkg = $_;
        } else {
            my @fields = split;
            push @{$obsolete_conffiles{$curr_pkg}}, $fields[0]
              if $fields[$#fields] eq "obsolete"
              and not exists $known_bad_obsolete_conffiles{$fields[0]};
        }
    }
    unless (keys %obsolete_conffiles == 0) {
        my @all_obsolete_conffiles;
        say_bold "Obsolete conffiles:\n";
        foreach my $pkg (keys %obsolete_conffiles) {
            foreach my $file (@{$obsolete_conffiles{$pkg}}) {
                print "  $pkg\t$file\n";
                push @all_obsolete_conffiles, $file;
            }
        }
        print "\nPlease report bugs if these files unedited by the local administrator,\n"
         . "and then, can attempt to fix by deleting each conffile and reinstalling\n"
         . "its package -- but note that this is not the right fix if the conffile has\n"
         . "moved between packages.\n\n";
        if (prompt_yn "Attempt the fix?") {
            system as_root "rm @all_obsolete_conffiles";
            system as_root join ' ',
              "apt-get install -y --reinstall",
              keys %obsolete_conffiles;
        }
    }

    # Point of this is so that if the apt upgrade undid any config,
    # it'll get restored before we attempt a reboot -- then can always
    # choose to accept the maintainer's conffile during the above
    # upgrades.
    #
    # On hosts which are manually spun or spun only when online, also
    # useful refresh sbuild chroots
    system as_root "test -x /root/.cache/consfigurator/images/latest";
    if ($? == 0 and prompt_Yn "Deploy this host with Consfigurator?") {
        interactive_ensure_subroutine_success sub {
            system_pty_capture as_root
              "/root/.cache/consfigurator/images/latest";
        };
    }

    if (($suite ne STABLE || -e "/var/run/reboot-required")
        && prompt_yn("Should reboot; do it now?")) {
        exec as_root("reboot");
    }
}

=head2 empty_dir_or_list($dir)

Check whether C<$dir> contains any hidden or unhidden files, returning
a true value if it does not, a false value if it does.  If it does,
print them.

As a special exception, ignore zero-sized files named '.keep' (which
is used to prevent empty directories getting clobbered by things like
snap) and 'emacs-notes'.

=cut

sub empty_dir_or_list {
    my ($dir) = @_;

    opendir(my $dirh, $dir);
    my @files
      = grep $_ ne '.'
      && $_ ne '..'
      && !(($_ eq ".keep" || $_ eq "emacs-notes") && -z catfile $dir, $_),
      readdir $dirh;

    if (@files == 0) {
        return 1;
    } else {
        $dir =~ s/$ENV{HOME}/~/;
        say_bold("Listing $dir:\n");
        print "  $_\n" for @files;
        return 0;
    }
}

=head2 loose_src_files()

Check whether there are loose plain files outside of repos in ~/src,
returning a true value if there are, a false value if not.  If there
are, print them.

=cut

sub loose_src_files {
    my @loose_src_files;
    find({wanted => sub {
              push @loose_src_files, $File::Find::name
                unless -d
                # permit orig.tars with associated source trees
                || ((-f || -l)
                    && /([^_]+)_([^_]+)\.orig(?:\.gbp)?\.tar/
                    && exists $Local::Homedir::debian_source_repos{$1})
          }, preprocess => sub {
              # don't look inside any worktrees
              return grep !Local::Homedir::is_repo($_), @_
          }}, "$ENV{HOME}/src");
    if (@loose_src_files == 0) {
        return 0;
    } else {
        say_bold("The following files in ~/src should be cleaned up:");
        print "  $_\n" for @loose_src_files;
        return 1;
    }
}

=head backup_repo($uri, $dest)

Back up git repo at C<$uri> to destination directory C<$dest>,
appending a '.git' to the latter if necessary.

Handle annexes listed in C<@remote_annexes> specially.

Requires Git::Wrapper to be available.  Code that calls
C<backup_repo()> should ensure it's available.

=cut

sub backup_repo {
    my ($uri, $dest) = @_;

    my ($paired_annex, $lazy_paired_annex, $synconlyannex)
      = map +(catfile($ENV{HOME}, $_->{homedir}), $_->{lazy},
        $_->{synconlyannex}), grep $_->{origin} eq $uri, @remote_annexes;
    $dest = "$dest.git" unless $dest =~ /\.git\z/;
    my $do_origin_fetch = !$paired_annex || $synconlyannex;

    # when we are backing up a paired annex, we need to be on a
    # removable drive under /media, because that's going to be the
    # annex description
    my $desc;
    if (defined $paired_annex) {
        $dest =~ m|^/media/[^/]+/([^/]+)/|;
        die "failed to determine drive label for $dest" unless defined $1;
        $desc = $1;
    }

    # report status
    if (defined $paired_annex) {
        script_status("backing up $uri to $dest as annex");
    } else {
        script_status("backing up $uri to $dest");
    }

    my $clone_needed;
    if (-e $dest && !-d $dest) {
        die "$dest exists but is not a directory";
    } elsif (-d $dest) {
        opendir my $dirh, $dest or die "failed to opendir $dest";
        readdir $dirh;
        readdir $dirh;
        # if we fail to read a third entry, the dir only had . and
        # .. in it, so we need to clone
        $clone_needed = ! readdir $dirh;
    } else {
        $clone_needed = 1;
    }
    return if $clone_needed and defined $paired_annex and $lazy_paired_annex;
    if ($clone_needed) {
        make_path($dest) unless -d $dest;
        # bare repos don't get a reflog by default
        system "git -C $dest -c core.logAllRefUpdates=true clone "
          . ($do_origin_fetch ? "--mirror" : "--bare") . " $uri .";
    }
    my $git = Git::Wrapper->new($dest);

    # Protect our backup from being reaped by git-gc.
    #
    # Enable the reflog, since it is off by default in bare repos.
    # Since we fetch with --no-prune, no reflogs will ever get
    # deleted, so we have one for every branch that ever existed in
    # the remote we're backing up (that existed at a time we ran this
    # script, at least)
    $git->config(qw(core.logAllRefUpdates true));
    # Never remove reflog entries
    $git->config(qw(gc.reflogExpire never));
    # git-gc will never remove dangling commits mentioned in any
    # reflog *unless* they are unreachable in the branch the
    # reflog logs and are older than this config variable
    $git->config(qw(gc.reflogExpireUnreachable never));
    # avoid backing up broken commits
    $git->config(qw(fetch.fsckObjects true));

    if (defined $paired_annex) {
        if ($clone_needed) {
            $git->annex("init", $desc);
            # set these content settings now, but the user might want to
            # change for this particular backup drive
            $git->config(qw(annex.diskreserve 2GB));
            $git->annex(qw(wanted . standard));
            $git->annex(qw(group . incrementalbackup));
            if ($synconlyannex) {
                system "git", "branch", "-D", "git-annex";
                $git->config("--add", "remote.origin.fetch",
                    "^refs/heads/git-annex");
                $git->config("--add", "remote.origin.fetch",
                    "^refs/heads/synced/git-annex");
            }
        }
        if (-d catfile($paired_annex, ".git")
              && -d catfile($paired_annex, ".git", "annex")) {
            my $pair = Git::Wrapper->new($paired_annex);
            my @remotes = $pair->remote();
            $pair->remote("add", $desc, $dest)
              unless (grep /^$desc$/, @remotes);
            $synconlyannex and $git->config("annex.synconlyannex", "true");
            # bypass Git::Wrapper so that output is printed
            interactive_ensure_subroutine_success(
                sub {
                    system_pty_capture(
                        "git -C $paired_annex annex sync --content $desc");
                });
            interactive_ensure_subroutine_success(
                sub {
                    system_pty_capture(
                        "git -C $paired_annex annex sync --no-content origin");
                }) if grep /^origin$/, @remotes;
        } else {
            say_bold("$paired_annex doesn't look like an annex"
                     . " on this machine, so not updating $dest");
            get_ack();
        }
    }
    if (
        $do_origin_fetch
        and !$clone_needed
        # additional check to avoid accidental ref clobbering
        and ($synconlyannex or !-d catfile($dest, ".git", "annex"))
    ) {
        my ($origin) = $git->config(qw(remote.origin.url));

        die "$dest has origin remote URI $origin but we expected $uri"
          unless ($origin eq $uri)
          # accommodate repos created by coldbkup part of sysmaint --
          # these don't use the athena:/athenap:/athenag: aliases
          || ("$origin $uri"
              =~ m|git\@spwhitton\.name:(.+)(?:\.git)? athena:\1|)
          || ("$origin $uri"
              =~ m|git\@spwhitton\.name:priv/(.+)(?:\.git)? athenap:\1|)
          || ("$origin $uri"
            =~ m|gcrypt::rsync://athena:/srv/gcrypt/(.+) athenag:\1|);

        my $fetch = "--tags --no-prune +refs/heads/*:refs/heads/*";
        $synconlyannex
          and $fetch .= " ^refs/heads/git-annex ^refs/heads/synced/git-annex";

        # bypass Git::Wrapper so that fetch output is shown to the user
        interactive_ensure_subroutine_success(
            sub { system_pty_capture "git -C $dest fetch origin $fetch" });
    }
}

=head find_old_coldbkups($directory, \@backups)

Find git repos in C<$directory> which do not have entries in
C<\@backups>.  C<@backups> is an array of hashrefs, where the C<dir>
key of each hash is the relative path to the git repo under
C<$directory>.

=cut

sub find_old_coldbkups {
    my ($directory, $backups) = @_;
    $directory = rel2abs($directory);
    my @dirs = map { $_->{dir} } @$backups;
    my @repos;
    find({
            wanted =>
              sub { -d and /\.git$/ and push @repos, abs2rel($_, $directory) },
            # we have to recurse into subdirs because we have repos in
            # subdirs of the repo root on athena, but for speed, avoid
            # looking inside git or git annex objects dirs
            preprocess => sub {
                grep { !/\A(objects|tmp|transfer|journal)\z/ } @_;
            },
            no_chdir => 1
        },
        $directory
    );
    my @old_coldbkups = array_minus(@repos, @dirs);
    if (@old_coldbkups == 0) {
        return 0;
    } else {
        say_bold("Repos in $directory not present on the remote:");
        print "  $_\n" for @old_coldbkups;
        return 1;
    }
}