#!/usr/bin/perl

# This is meant to walk me through maintenance tasks that
# can't/shouldn't happen unattended by means of Propellor and/or cron
# jobs installed by Propellor.
#
# That includes, at least:
#
# - apt upgrades of bare metal hosts (other than automatic security
#   upgrades)
#
# - checking in and backing up homedirs, which I need to do on all
#   machines, not just those for which I am root
#
# - cleaning up temporary files, old packages etc.
#
# - backups to devices usually kept offline
#
# Assumptions we make:
#
# - We expect a bunch of perl libraries and utilities to be installed.
#
# - 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.

use strict;
use warnings;
use lib "$ENV{HOME}/src/dotfiles/perl5";
no warnings "experimental::smartmatch";

use Dpkg::Version;
use Term::UI;
use File::Which;
use File::Slurp;
use ShellSequence;
use ScriptStatus;
use File::Grep "fgrep";
use File::Basename;
use File::chdir;
use Capture::Tiny qw/capture_merged capture/;
use List::MoreUtils "apply";
use File::Spec::Functions "rel2abs";
use Switch;
use Sys::Hostname;
use Sys::Hostname::Long;

# ---- globals

my $seq = ShellSequence->new();
my $term = Term::ReadLine->new('brand');
my $user = $ENV{LOGNAME} || $ENV{USER} || getpwuid($<);
my $host = hostname;
my $longhost = hostname_long;

# ---- config

# where are our git repos?  a host defined in ~/.ssh/config
our $git_host = "athena";

# on the $git_host, where are our repositories?
our $git = "/srv/git/repositories";

# on the $git_host, where are our git-remote-gcrypt repos?
# (we have them in a separate dir because we use exclusively gcrypt's
# rsync mode.  otherwise, if mixed in with regular git repos, gcrypt
# has a --check option)
our $gcrypt = "/srv/gcrypt";

# annexes that should be inited on backup drives, and synced with the
# corresponding annex in $HOME.  This list is manually maintained
# because I do not want this script to run `git annex init` in lots of
# repos, creating bogus UUIDs
my @annexes = qw/annex.git wikiannex.git dionysus.git/;

# hosts configuration
#
# This config is meant to set the contents of some variables, the
# default values and meanings of which are:
#
# - $can_sudo = 0;            whether we can become root using sudo(1) on this host
#
# - $can_push = 0;            whether we can push any of our git repos in $HOME to
#                             their origin remotes (if can push some, set to '1'
#                             and use .mrconfig to avoid trying to push the others)
#
# - $check_for_extdrive = 0;  whether we should expect to have an
#                             external drive plugged in and referenced on the
#                             command line
#
# - $can_run_duply = 0;       whether there exists duply config we can run to
#                             backup the homedir after syncing it

# TODO factor out 'sudo' hardcoded throughout script; don't pass if it
# we are already root

our $can_sudo = 0;
our $can_push = 1;
our $check_for_extdrive = 0;
our $can_run_duply = 0;
switch ("$user\@$longhost") {
    case /^root@/                             { $can_sudo = 1; $can_push = 0; last }
    case /\.silentflame\.com$/                { $can_sudo = 1; $can_push = 1; next }
    case /\@develacc.*\.silentflame\.com$/    { $can_push = 0; next }

    case /iris\.silentflame\.com$/            { $check_for_extdrive = $can_run_duply = 1; next }
    case /hephaestus\.silentflame\.com$/      { $check_for_extdrive = $can_run_duply = 1; next }
    case /zephyr\.silentflame\.com$/          { $check_for_extdrive = $can_run_duply = 1; next }
}

# ---- prep

chdir $ENV{HOME};
my ($loc, $drive_name, $short_drive_name);

my @ARGV_positional = grep { $_ !~ m/^--/ } @ARGV;
my @ARGV_options = grep { $_ =~ m/^--/ } @ARGV;

if (@ARGV_positional) {
    $loc = rel2abs(shift @ARGV_positional);
    $drive_name = $loc;
    $short_drive_name = basename $drive_name;

    my @mountpoints = split /^/, `mount | cut -d' ' -f3`;
    @mountpoints = apply { $_ =~ s/^\s+|\s+$//g } @mountpoints;

    # if it's not mounted, see if we can get it mounted
    # gvfs-mount(1) is a possible alternative to using udisksctl directly
    system "udisksctl mount --object-path $loc" unless ( -d $loc );

    die "$loc is not a directory" unless ( -d $loc );
    die "$drive_name is not a removable drive" unless ( $drive_name ~~ @mountpoints );

    if ( ! -d "$loc/gitbk" ) {
        status "it looks like you haven't backed up to this media before";
        my $create = $term->ask_yn(prompt => "Create a new backup repository at $loc/gitbk?");
        if ($create) {
            mkdir "$loc/gitbk"
              or die "couldn't create $loc/gitbk -- check permissions";
        } else {
            exit 1;
        }
    }
} elsif ($check_for_extdrive) {
    status "you didn't specify a drive to perform a coldbkup to as a command";
    status "line argument to this script";
    exit unless $term->ask_yn(
                              prompt => "Continue sysmaint without coldbkup?",
                              default => 'y',
                             );
}

User:

goto System if ("--skip-user" ~~ @ARGV_options
                || "--only-system" ~~ @ARGV_options);

# ---- pre-backup cleanup tasks

$seq->should_zero("ls tmp");
$seq->should_succeed("src-register-all");

status "cleaning up ~/src";
clean_orig_tars();
unlink glob "src/*.dsc";
unlink glob "src/*.diff.gz";
unlink glob "src/*.upload";
unlink glob "src/*.inmulti";
unlink glob "src/*.changes";
unlink glob "src/*.deb";
unlink glob "src/*.build";
unlink glob "src/*.buildinfo";
unlink glob "src/*.debian.tar.*";
unlink glob "src/*[0-9~].tar.*"; # native package generated tarballs
system "clean-patch-queues -y";

while (42) {
    my $output = capture_merged { find_dirty_src() };
    if (length $output) {
        status "the following files/repos in ~/src should be cleaned up:";
        print $output;
        my $again = $term->ask_yn(
                                  prompt => "Check for files in ~/src again?",
                                  default => 'y',
                                 );
        last unless $again;
    } else {
        last;
    }
}

# files not included in duplicity backups
$seq->should_succeed("ls local/big");
# files I don't want to check into git but small enough to include in
# duplicity backups, but should not stick around in ~/tmp
$seq->should_succeed("ls local/tmp");
# files to be temporarily shared over the LAN
$seq->should_succeed("ls local/pub");
$term->get_reply(
                 prompt => "Consider cleaning up/annexing files in these three dirs.",
                 default => 'okay',
                );
$seq->should_succeed("ls");
$term->get_reply(
                 prompt => "Clean up any loose files in ~",
                 default => 'done',
                );

# ---- standard backup procedure

# run a restow to catch if we need to run `mr adopt`
$seq->add_should_succeed("mr -ms restow");
$seq->add_should_succeed("mr -ms autoci");
# `mr -ms isclean` checks for stuff to be checked in ...
$seq->add_should_succeed("mr -ms isclean");
$seq->add_should_succeed("mr -s up");
$can_push and $seq->add_should_succeed("mr -s push");
# ... then `mr -ms status` finds unpushed branches & stashes
$seq->add_should_zero("mr -ms status");

$seq->run();

# ---- backup to offline media ("coldbkup" was old script name)

# TODO error handling here: since we're not using $seq for everything
if ( defined $loc ) {

    # ---- github-backup
    # handed over to a cronjob on athena
    # {
    #     mkdir "$loc/gitbk/github" unless ( -d "$loc/gitbk/github" );
    #     local $CWD = "$loc/gitbk/github";
    #     # TODO should login to github API to work around rate limiting
    #     $seq->add_should_succeed("github-backup spwhitton");
    #     $seq->run();
    # }

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

    if ( eval "use Net::GitHub; 1" ) {
        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;
            # TODO have backup_repo support 'github/$org' i.e. handle
            # creating subdirectories, which it can't do yet.  And
            # then clean up github_*/ and github/foo where
            # github/foo/.git exists (i.e. clean up stuff done by old
            # versions of sysmaint)
            backup_repo($repo->{clone_url}, "github_$org");
        }
    }

    # ---- athena repos
    my $athena_git_repos = capture {
        system "ssh athena 'for d in $git/*.git $git/*/*.git; do echo \$d; done'";
    };
    my $athena_gcrypt_repos = capture {
        system "ssh athena 'for d in $gcrypt/*; do echo \$d; done'";
    };
    my @athena_git_repos = split /^/, $athena_git_repos;
    @athena_git_repos = apply { s|$git/|| } @athena_git_repos;
    my @athena_gcrypt_repos = split /^/, $athena_gcrypt_repos;
    @athena_gcrypt_repos = apply { s|$gcrypt/|| } @athena_gcrypt_repos;

    foreach my $repo ( @athena_git_repos ) {
        $repo =~ s/\n//g;

        backup_repo("git\@spwhitton.name:$repo", "athena");
    }

    foreach my $repo ( @athena_gcrypt_repos ) {
        $repo =~ s/\n//g;
        backup_repo("gcrypt::rsync://athena:/srv/gcrypt/$repo", "athena_gcrypt");
    }

    # ---- misc. repos

    # Debian packages I'm responsible for, and a few other Debian repos

    # TODO move this into text files in ~/doc/conf/

    backup_repo("https://salsa.debian.org/emacsen-team/dh-elpa", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/yasnippet", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-async", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-highlight-indentation", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-noflet", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/f-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/flx", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/flycheck", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/let-alist", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/paredit-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/parsebib", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/perspective-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/pkg-info-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/popup-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/projectile", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/persp-projectile", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/helm-projectile", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/rainbow-delimiters", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/seq-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/s-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/dash-functional-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/shut-up", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/smex", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/ws-butler", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/zenburn-emacs", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/aggressive-indent-mode", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/ert-async-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/git-annex-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/debpaste-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/magit-annex", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/xml-rpc-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/wc-mode", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/key-chord-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/paredit-everywhere", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/visual-regexp-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/pointback", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-openwith", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-world-time-mode", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/helm-dash", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/message-templ", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/esxml", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-db", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-kv", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-helm-ag", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/queue-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/spinner-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/cider", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/helm", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/epl", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/deft", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/ebib", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/dh-make-elpa", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/nov-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/yasnippet-snippets", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/emacs-buttercup", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/dash-el", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/redtick", "salsa");
    backup_repo("https://salsa.debian.org/emacsen-team/wiki", "salsa", "pkg-emacsen");
    backup_repo("https://salsa.debian.org/emacsen-team/sesman", "salsa", "pkg-emacsen");

    backup_repo("https://salsa.debian.org/haskell-team/git-annex", "salsa");

    backup_repo("https://salsa.debian.org/python-team/modules/pikepdf", "salsa");
    backup_repo("https://salsa.debian.org/python-team/modules/pytest-helpers-namespace", "salsa");

    backup_repo("https://salsa.debian.org/dbnpolicy/policy", "salsa");
}

# attempt to unmount the drive we just backed up to
if ( defined $loc ) {
    # gvfs-mount(1) is a possible alternative to using udisksctl directly
    $seq->add_should_succeed("udisksctl unmount --object-path $loc");
    $seq->add_should_succeed("udisksctl power-off --object-path $loc");
}

# ---- update duplicity backups now that all syncing is done

# TODO  How about turning off MAX_FULLBKP_AGE such that only sysmaint
# performs a full backup?  This eliminates the random coffee shop WiFi
# problem.  Document that we're using that strategy, for laptops only,
# in the duplicity config file.
#
# (in locmaint, we're achieving this by forcing incremental backups
# rather than turning off MAX_FULLBKP_AGE, so that the 'backup'
# subcommand still respects MAX_FULLBKP_AGE as that might useful)

if ( $can_run_duply ) {
    $seq->add_should_succeed("duply $host-$user-home backup");
}

$seq->run();

# ---- local system maintenance

System:

exit unless $can_sudo;
exit if ("--skip-system" ~~ @ARGV_options);
exit if ("--only-user" ~~ @ARGV_options);

unless ("--only-system" ~~ @ARGV_options || "--skip-user" ~~ @ARGV_options) {
    exit unless $term->ask_yn(
                          prompt =>
                          "Backups complete.  Perform local system maintainance?"
                         );
}

$seq->should_succeed("df -h");
$term->get_reply(
                 prompt => "Confirm that host has enough disc space, or clean up some files.",
                 default => 'done',
                );

if ($longhost eq "athena.silentflame.com") {
    $seq->should_succeed("uptime");
    $term->get_reply(
                     prompt => "If athena was rebooted, perform athena reboot procedure.",
                     default => 'done',
                    );
}

# clean packages installed by mk-build-deps(1)
my $build_deps_to_be_purged = `dpkg -l | awk '/-build-deps/ { print \$1 "  " \$2 "  " \$3}'`;
if ($build_deps_to_be_purged) {
    print $build_deps_to_be_purged;
    $seq->should_succeed("sudo aptitude -y purge '~n-build-deps\$'")
      if $term->ask_yn(
                       prompt => "Finished with these?",
                       default => 'n',
                      );
}

$seq->add_should_succeed("sudo apt-get update");
# This 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.)
$seq->add_should_succeed("sudo apt-get --with-new-pkgs upgrade");
$seq->add_should_succeed("sudo apt-get dist-upgrade");
$seq->add_should_succeed("sudo apt-get -y autoremove");
$seq->add_should_succeed("sudo apt-get autoclean");

# TODO check if mailq is executable by us or skip this
which 'mailq' and $seq->add_should_zero("mailq | grep -v 'Mail queue is empty'");
$seq->run();

# additional system cleanup tasks

my $to_be_purged = `dpkg -l | awk '/^rc/ { print \$1 "  " \$2 }'`;
if ($to_be_purged) {
    print $to_be_purged;
    $seq->should_succeed("sudo apt-get purge \$(dpkg -l | awk '/^rc/ { print \$2 }')")
      if $term->ask_yn(
                       prompt => "Purge these?"
                      );
}

# TODO only try to do this on Debian stable hosts, because often the
# running kernel will be an obsolete package on testing/unstable, and
# in general we can only expect this to work well on stable
#
# (but we probably want to clean up obsolete packages on testing/sid
# as they will build up.  so just add code here to filter out the
# running kernel?)
#
# (even then probably don't run it on testing because packages
# disappear and reappear.  but we can expect this to work reliably on
# sid, I think)
my $obsolete = `aptitude search ?obsolete`;
if ($obsolete) {
    print $obsolete;
    $seq->should_succeed("sudo aptitude -y purge ?obsolete")
      if $term->ask_yn(
                       prompt =>
                       "Remove these packages, which are no longer available from any mirrors?",
                       default => 'n',
                      );
}

my $obsolete_rc = `dpkg-query -W '-f=\${Package}\\n\${Conffiles}\\n' | awk '/^[^ ]/{pkg=\$1}/ obsolete\$/{print pkg,\$0}'`;
if ($obsolete_rc) {
    print $obsolete_rc;
    my $fix = $term->ask_yn(
                            prompt =>
                            "Fix these obsolete conffiles by deleting them, and reinstalling the packages providing them?",
                           );
    if ($fix) {
        for my $line (split '\n', $obsolete_rc) {
            my ($pkg, $rc) = split ' ', $line;
            # print "would delete: $rc\n";
            # print "would reinstall: $pkg\n";
            $seq->add_should_succeed("sudo rm $rc");
            $seq->add_should_succeed("sudo apt-get install --reinstall $pkg");
            $seq->run();
        }
    }
}

my $debian_version = read_file("/etc/debian_version");
chomp $debian_version;
if ($debian_version =~ m|/sid$| || -e "/var/run/reboot-required") {
    $seq->should_succeed("sudo reboot")
      if $term->ask_yn(
                       prompt => "Should reboot; do it now?",
                       default => 'n',
                      );
}

# ---- subroutines

sub clean_orig_tars {
    my $origs = {};
    foreach my $f ( glob "src/*.orig.tar.*" ) {
        $f =~ m/src\/([^_]*)_/;
        push @{$origs->{"$1"}}, $f;
    }
    sub orig_ver {
        $a =~ m/src\/[^_]*_([^_]*)\.orig/;
        my $ver_a = Dpkg::Version->new("$1");
        $b =~ m/src\/[^_]*_([^_]*)\.orig/;
        my $ver_b = Dpkg::Version->new("$1");
        version_compare($ver_a, $ver_b);
    }
    foreach my $pkg (keys %$origs) {
        my @origs = sort orig_ver @{$origs->{$pkg}};
        if ( -d "src/$pkg/.git" ) {
            if ( scalar @origs > 2 ) {
                @origs = splice @origs, 0, -2;
            } else {
                @origs = ();
            }
        }
        foreach my $orig ( @origs ) {
            unlink $orig;
        }
    }
}

sub find_dirty_src {
    foreach my $f ( glob "src/*" ) {
        my $short = basename($f);
        unless ( (-f $f && $f =~ /orig\.tar/)
                 # also permit symlinks to orig tarballs
                 || (-l $f && $f =~ /orig\.tar/)
                 # also permit gbp orig tarballs
                 || ($f =~ /orig\.gbp\.tar/)
                 || -d "$f/.git" || -d "$f/.hg" # handled by src-register-all
               ) {
            print "$f\n";
        }
    }
}

sub backup_repo {
    my ( $long, $dest, $rename ) = @_;
    my $short;

    # flush the command sequencer
    $seq->run();
    # third param is optional: do we need to rename it because
    # remote's name is too generic (e.g. 'wiki')?
    if ( defined $rename ) {
        $short = $rename;
    } else {
        if ( $long =~ m/^http/ ) {
            ( undef, $short ) = split /\/([^\/]+)$/, $long;
        } else {
            ( undef, $short ) = split /:([^:]+)$/, $long;
        }
        $short =~ s/\/srv\/(git|gcrypt)\///;
    }

    $short = "$short.git" unless $short =~ /\.git$/;
    my $vshort = basename $short;
    $dest = "$loc/gitbk/$dest";
    my $dir = "$dest/$short";
    status "backup source: $long";
    status "backup dest:   $dir";

    # first we have to determine whether it's an annex, as that will
    # affect the commands we run both to clone and to update
    my $annex = 0;
    if ( $dest eq "$loc/gitbk/athena" && $vshort ~~ @annexes ) {
        $annex = 1;
    }

    if ( -e $dir ) {            # repo already backed up to this drive
        local $CWD = $dir;
        # TODO second disjunct in to allow for non-bare repos on
        # backup drive, e.g. gitbk/athena/annex on m3.  At present,
        # gitbk/athena/annex.git is a symlink to gitbk/athena/annex.
        # We should be able to handle this without the symlink, in
        # this script
        if ( -d "annex" || -d ".git/annex" ) {
            system "git config annex.diskreserve '2GB'";
            # TODO ask user before pairing since it's a guess
            if ( my $host_repo = find_host_annex($vshort) ) {
                status "pairing $short with $host_repo";
                local $CWD = $host_repo;
                system "git remote add $short_drive_name $dir 2>/dev/null" || 1;
                $seq->should_succeed("git annex sync --content $short_drive_name");
                # TODO now metadata sync with origin remote, if it exists
            } else {
                # TODO extend ShellSequence to run arbitrary perl,
                # then this whole thing can be retried
                status "couldn't pair $short with host; not syncing it";
                my $acknowledged = $term->ask_yn(
                                                 prompt => "Acknowledged?",
                                                 default => 'y',
                                                );
            }
        } else {
            # TODO verify origin remote is what we expect, or error
            # out: user probably needs to update backup drive layout
            $seq->should_succeed("git fetch origin '+refs/heads/*:refs/heads/*' --tags --no-prune");
        }
    } else {                    # repo new to this drive
        if ($annex) {
            mkdir "$dest" unless ( -d $dest );
            local $CWD = $dest;
            # bare repos don't get a reflog by default
            system "git -c core.logAllRefUpdates=true clone --bare $long $short";
            {
                local $CWD = $dir;
                system "git annex init '$short_drive_name'";
                system "git config annex.diskreserve '2GB'";
                # only set preferred content settings on a first init,
                # so that the user can override for this particular
                # backup drive
                system "git annex wanted . standard";
                system "git annex group . incrementalbackup";
                # TODO ask user before pairing since it's a guess
                if ( my $host_repo = find_host_annex($vshort) ) {
                    status "pairing $short with $host_repo";
                    local $CWD = $host_repo;
                    system "git remote add $short_drive_name $dir 2>/dev/null" || 1;
                    $seq->should_succeed("git annex sync --content $short_drive_name");
                    # TODO now metadata sync with origin remote, if it exists
                } else {
                    status "couldn't pair $short with host; not syncing it";
                    my $acknowledged = $term->ask_yn(
                                                     prompt => "Acknowledged?",
                                                     default => 'y',
                                                    );
                }
            }
        } else {
            mkdir "$dest" unless ( -d $dest );
            local $CWD = $dest;
            # bare repos don't get a reflog by default
            $seq->should_succeed("git -c core.logAllRefUpdates=true clone --mirror $long $short");
        }
    }

    # Protect our backup from being reaped by git-gc
    {
        local $CWD = $dir;
        # 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)
        system "git config core.logAllRefUpdates true";
        # Never remove reflog entries
        system "git config 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
        system "git config gc.reflogExpireUnreachable never";
        # avoid backing up broken commits
        system "git config fetch.fsckObjects true";
    }
}

sub find_host_annex {
    my $annex = shift;
    $annex =~ s|\.git$||;

    # parse output of `mr list`
    my @my_repos = split /^/, `mr -d $ENV{HOME} list`;
    @my_repos = apply { s/mr list:// } @my_repos;
    @my_repos = apply { $_ =~ s/^\s+|\s+$//g } @my_repos;
    @my_repos = grep { /^\// } @my_repos;

    # TODO check if they have any commits in common
    my @found = grep { $_ =~ /\/$annex$/ } @my_repos;
    return $found[0] if ( scalar @found == 1 );
}