#!/usr/bin/env perl
# Copyright (C) 2015-2023 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 .
# 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;
# this host's Debian suite
our $suite;
# 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_dist_upgrade;
my $want_skip_update;
GetOptions('homedir|home!' => \$want_homedir,
'coldbkup|cold!' => \$want_coldbkup,
'workstation-duplicity|duplicity|duply!'
=> \$want_workstation_duplicity,
'sysmaint|sys!' => \$want_sysmaint,
'dist-upgrade=s' => \$want_dist_upgrade,
'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(), do_maybe_reboot() if $do_sysmaint;
if ($want_dist_upgrade) {
system as_root
"rm -f /etc/cron.daily/consfigurator /root/.cache/consfigurator/images/latest";
open my $sources_in, "<", "/etc/apt/sources.list";
my @lines;
for (<$sources_in>) {
my @F = split;
$F[2] =~ s/\A[a-z]+/\Q$want_dist_upgrade\E/;
push @lines, join " ", @F;
}
print "\n";
open my $sources_out, "|-", as_root "tee /etc/apt/sources.list";
print $sources_out "$_\n" for @lines;
close $sources_out;
say_spaced_bullet("Host's /etc/apt/sources.list updated as shown.");
get_ack();
do_apt_update();
do_apt_upgrade();
say_bold("Update host's suite in consfig and deploy, before reboot.");
get_ack();
do_maybe_reboot();
}
# 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)
#
# local/pub: files to be temporarily shared over the LAN
my $empty = 1;
$empty = empty_dir_or_list($_) && $empty
for qw(local/big local/tmp local/pub);
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" : "incr"), "--force";
}
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.
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();
do_apt_update();
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?");
}
do_apt_upgrade();
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";
};
}
}
sub do_apt_update {
script_status("updating apt indices");
system as_root("apt-get update");
die "apt-get update failed" unless $? == 0;
}
sub do_apt_upgrade {
# 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 autoremove")) });
script_status("autocleaning apt's cache");
interactive_ensure_subroutine_success(
sub { system_pty_capture(as_root("apt-get autoclean")) });
}
sub do_maybe_reboot {
if (($suite && $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 'scratch'.
=cut
sub empty_dir_or_list {
my ($dir) = @_;
opendir(my $dirh, $dir);
my @files
= grep $_ ne '.'
&& $_ ne '..'
&& !(($_ eq ".keep" || $_ eq "scratch") && -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 sort @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 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
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;
}
}