1 #! /usr/bin/perl

     2 use strict;

     3 use warnings;

     4 

     5 use IO::File;

     6 use File::Basename;

     7 use Net::FTP;

     8 use Perl6::Slurp;

     9 use Getopt::Long;

    10 use Sys::Hostname;

    11 use Pod::Usage;

    12 use POSIX qw(strftime);;

    13 use English qw(-no_match_vars);

    14 use 5.10.0;

    15 use if $ENV{DEBUG} => qw(Smart::Comments);

    16 

    17 $ENV{LC_ALL} = "C";

    18 

    19 my $ME = basename $0;

    20 

    21 my @CONFIGS = ("/etc/$ME", "$ENV{HOME}/.$ME", "$ME.conf");

    22 

    23 my $NODE = hostname;

    24 my $NOW = time();

    25 

    26 my $opt_level = 0;

    27 my $opt_today = strftime("%F", localtime $NOW);

    28 my @opt_debug = ();

    29 my $opt_verbose = 0;

    30 my $opt_dry = 0;

    31 my $opt_force = 0;

    32 

    33 sub get_configs(@);

    34 sub get_candidates();

    35 sub verbose(@);

    36 

    37 our @AT_EXIT;

    38 END { $_->() foreach @AT_EXIT };

    39 $SIG{INT} = sub { warn "Got signal INT\n"; exit 1 };

    40 

    41 my %CONFIG = (

    42     FTP_DIR => "backup/daily/$NODE",

    43     FTP_PASSIVE => 1,

    44     FULL_CYCLE => 7,	    # not used

    45 );

    46 

    47 MAIN: {

    48     GetOptions(

    49 	"l|level=i" => \$opt_level,

    50 	"d|debug:s" => sub { push @opt_debug, split /,/, $_[1] },

    51 	"h|help" => sub { pod2usage(-exit => 0, -verbose => 1) },

    52 	"m|man" => sub { pod2usage(-exit => 0, -verbose => 3) },

    53 	"v|verbose" => \$opt_verbose,

    54 	"dry" => \$opt_dry,

    55 	"f|force" => \$opt_force,

    56     ) or pod2usage;

    57 

    58     my %cf = (%CONFIG, get_configs(@CONFIGS));

    59     my @dev = get_candidates();

    60     ### current candiates: @dev

    61 

    62     my $ftp = new FTP($cf{FTP_HOST}, 

    63 	Passive => $cf{FTP_PASSIVE}, 

    64 	Debug => @opt_debug ~~ /^ftp$/) or die $@;

    65     $ftp->login or die $ftp->message;

    66     $ftp->try(binary => ());

    67     $ftp->try(mkpath => $cf{FTP_DIR});    

    68     $ftp->try(cwd => $cf{FTP_DIR});

    69 

    70     given ($opt_level) {

    71 	when(0) {

    72 	    $ftp->try(mkpath => $opt_today);

    73 	    $ftp->try(cwd => $opt_today);

    74 	}

    75 	default {

    76 	    # find the last full backup directory

    77 	    my $last_full = (reverse sort grep /^\d{4}-\d{2}-\d{2}$/, $ftp->ls)[0];

    78 	    die "no last full backup found in @{[$ftp->pwd]}\n"

    79 		if not $last_full;

    80 	    $ftp->try(cwd => $last_full);

    81 	}

    82     }

    83 

    84     # now sitting inside the directory for the last full backup

    85     verbose "Now in @{[$ftp->pwd]}.\n";

    86 

    87     # and now we can start doing something with our filesystems

    88     foreach my $dev (@dev) {

    89 

    90 	my $file = basename($dev->{dev}) . "."

    91 	    . strftime("%F_%R", localtime $NOW)

    92 	    . ".$opt_level.ssl";

    93 	my $label = "$NODE:" . basename($dev->{rdev});

    94 	verbose "Working on $dev->{dev} as $dev->{rdev}, stored as $file\n";

    95 	next if $opt_dry;

    96 

    97 	## complain if there is already a full backup in this

    98 	## sequence

    99 	##die "level 0 dir should be empty\n" if @{$ftp->try(ls => "*.0.*")};

   100 

   101 	# For LVM do a snapshot, for regular partitions

   102 	# do nothing. But anyway the device to dump is named in $dev->{dump}

   103 	if ($dev->{lvm}) {

   104 	    # we can do a snapshot

   105 	    # FIXME: calculate the size

   106 	    my $snap = "$dev->{lvm}{path}-0";

   107 

   108 	    verbose "Creating snapshot $snap\n";

   109 	    system($_ = "lvcreate -s -L 1G -n $snap $dev->{lvm}{path} >/dev/null");

   110 	    die "failed system command: $_\n" if $?;

   111 

   112 	    $dev->{cleanup} = sub { system "lvdisplay $snap &>/dev/null"

   113 				      . " && lvremove -f $snap >/dev/null" };

   114 	    push @AT_EXIT, $dev->{cleanup};

   115 

   116 	    (my $device) = (grep /lv name/i, `lvdisplay $snap`)[0] =~ /(\S+)\s*$/;

   117 

   118 	    system($_ = "fsck -f -C0 -y $device");

   119 	    warn "fsck on $device (using: $_) failed\n" if $?;

   120 

   121 	    ($dev->{dump}) = $device;

   122 

   123 	}

   124 	else {

   125 	    $dev->{dump} = $dev->{rdev}

   126 	}

   127 

   128 	### $dev

   129 

   130 	$ENV{key} = $cf{KEY};

   131 	my $dumper = open(my $dump, "-|") or do {

   132 	    my $head = <<__;

   133 #! /bin/bash

   134 if test "\$1" = "--info"; then

   135     cat <<___

   136 NODE       : $NODE

   137 DATE       : $NOW @{[localtime $NOW]}

   138 LEVEL      : $opt_level

   139 DEVICE     : $dev->{dev}

   140 REAL_DEVICE: $dev->{rdev}

   141 MOUNTPOINT : $dev->{mountpoint}

   142 FSTYPE     : $dev->{fstype}

   143 ___

   144     exit 0

   145 fi

   146 tail -c XXXXX \$0 | openssl enc -d -blowfish "\$@"

   147 exit

   148 

   149 __

   150 	    # adjust the placeholder

   151 	    $head =~ s/XXXXX/sprintf "% 5s", "+" . (length($head) +1)/e;

   152 	    print $head;

   153 	    exec "dump -$opt_level -L $label -f- -u -z6 $dev->{dump}"

   154 	    . "| openssl enc -pass env:key -salt -blowfish";

   155 	    die "Can't exec dumper\n";

   156 	};

   157 

   158 	$ftp->try(put => $dump, $file);

   159 	$dev->{cleanup}->() if $dev->{cleanup};

   160 	verbose "Done.\n";

   161     }

   162 

   163 }

   164 

   165 sub verbose(@) {

   166     return if not $opt_verbose; 

   167     print @_;

   168 }

   169 

   170 sub get_candidates() {

   171 # return the list of backup candidates

   172 

   173     my @dev;

   174 

   175     # later we need the major of the device mapper

   176     my $dev_mapper = 0;

   177     $_ = (grep /device.mapper/, slurp("/proc/devices"))[0]

   178 	and $dev_mapper = (split)[0];

   179 

   180     foreach (slurp("/etc/fstab")) {

   181 	my ($dev, $mp, $fstype, $options, $dump, $check)

   182 	    = split;

   183 	next if not $dump;

   184 

   185 	# $dev does not have to contain the real device

   186 	my $rdev = $dev;

   187 	if ($dev ~~ /^(LABEL|UUID)=/) {

   188 	    chomp($rdev = `blkid -c /dev/null -o device -t '$dev'`);

   189 	}

   190 	$rdev = readlink $rdev while -l $rdev;

   191 

   192 	# if it's LVM we gather more information (to support snapshots)

   193 	# FIXME: could have used `lvdisplay -c'

   194 	my $lvm;

   195 	if ((stat $rdev)[6] >> 8 == $dev_mapper) {

   196 	    @{$lvm}{qw/vg lv/} = map { s/--/-/g; $_ } basename($rdev) =~ /(.+[^-])-([^-].+)/;

   197 	    $lvm->{path} = "$lvm->{vg}/$lvm->{lv}";

   198 	}

   199 

   200 	push @dev, {

   201 	    dev => $dev,

   202 	    rdev => $rdev,

   203 	    mountpoint => $mp,

   204 	    fstype => $fstype,

   205 	    lvm => $lvm,

   206 	};

   207     }

   208 

   209     return @dev;

   210 }

   211 

   212 sub get_configs(@) {

   213     local $_;

   214     my %r = ();

   215     foreach (grep {-f} map { (-d) ? glob("$_/*") : $_ } @_) {

   216 

   217 	# check permission and ownership

   218 	{

   219 	    my $p = (stat)[2] & 07777;

   220 	    my $u = (stat _)[4];

   221 	    die "$ME: $_ has wrong permissions: found @{[sprintf '%04o', $p]}, need 0600\n"

   222 		if $p != 0600;

   223 	    die "$ME: owner of $_ ($u) is not the EUID ($EUID) of this process\n"

   224 		if (stat _)[4] != $EUID;

   225 

   226 	    # FIXME: should check the containing directories too!

   227 	};

   228 

   229 	my $f = new IO::File $_ or die "Can't open $_: $!\n";

   230 	my %h = map { split /\s*=\s*/, $_, 2 } grep {!/^\s*#/ and /=/} <$f>;

   231 	map { chomp } values %h;

   232 	%r = (%r, %h);

   233     }

   234     return %r;

   235 }

   236 

   237 { package FTP; 

   238   use strict;

   239   use warnings;

   240   use base qw(Net::FTP);

   241 

   242   sub new {

   243     my $class = shift;

   244     return bless Net::FTP->new(@_) => $class;

   245   }

   246 

   247   sub try {

   248     my $self = shift;

   249     my $func = shift;

   250     $self->$func(@_)

   251 	or die "FTP $func failed: " . $self->message . "\n";

   252   }

   253 

   254   sub mkpath {

   255     my $self = shift;

   256     my $current = $self->pwd();

   257     foreach (split /\/+/, $_[0]) {

   258 	next if $self->cwd($_);

   259 	return undef if not $self->message ~~ /no such .*dir/i;

   260 	return undef if not $self->SUPER::mkdir($_);

   261 	return undef if not $self->cwd($_);

   262     }

   263     $self->cwd($current);

   264   }

   265 }

   266 

   267 __END__

   268 

   269 =head1 NAME

   270 

   271 py2b - backup tool

   272 

   273 =head1 SYNOPSIS

   274 

   275     py2b [--level <level>] [options]

   276 

   277 =head1 OPTIONS

   278 

   279 =over

   280 

   281 =item B<-d>|B<--debug> [I<item>]

   282 

   283 Enables debugging for the specified items (comma separated).

   284 If no item is specified, just some debugging is done.

   285 

   286 Valid items are B<ftp> and currently nothing else.

   287 

   288 Even more debugging is shown using the DEBUG=1 environment setting.

   289 

   290 =item B<-f>|B<--force>

   291 

   292 Use more power (e.g. overwrite a previous level backup and remove all

   293 invalidated other backups). (default: 0)

   294 

   295 =item B<-l>|B<--level> I<level>

   296 

   297 The backup level. Level other than "0" needs a previous

   298 level 0 (full) backup. (default: 0)

   299 

   300 =item B<-v>|B<--verbose>

   301 

   302 Be verbose. (default: no)

   303 

   304 =back

   305 

   306 =head1 FILES

   307 

   308 The config files are searched in the following places:

   309 

   310     /etc/py2b

   311     ~/.py2b

   312     ./py2b.conf

   313 

   314 If the location is a directory, all (not hidden) files in this directory are

   315 considered to be config, if the location a file itself, this is considered to

   316 be a config file. The config files have to be mode 0600 and they have to be 

   317 owned by the EUID running the process.

   318 

   319 =cut

   320 

   321 # vim:sts=4 sw=4 aw ai sm: