Rev 25 | Rev 31 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
package ZFS_Utils;
use strict;
use warnings;
use Exporter 'import';
use Data::Dumper;
use POSIX qw(strftime);
use File::Path qw(make_path);
our @EXPORT_OK = qw(loadConfig shredFile mountDriveByLabel mountGeli logMsg runCmd makeReplicateCommands $logFileName $displayLogsOnConsole);
our $VERSION = '0.1';
our $logFileName = '/tmp/zfs_utils.log'; # this can be overridden by the caller, and turned off with empty string
our $displayLogsOnConsole = 1;
our $merge_stderr = 0; # if set to 1, stderr is captured in runCmd
# Execute a command and return its output.
# If called in scalar context, returns the full output as a single string.
# If called in list context, returns the output split into lines.
# If $merge_stderr is true (default), stderr is merged into stdout (only for scalar commands).
# returns empty string or empty list on failure and logs failure message.
sub runCmd {
my $cmd = \@_;
$merge_stderr = 1 unless defined $merge_stderr;
my $output = '';
if (ref $cmd eq 'ARRAY') {
# Execute without a shell (safer). Note: stderr is not merged in this path.
logMsg( 'Running command [' . join ' ', @$cmd . ']');
open my $fh, '-|', @{$cmd} or do {
logMsg("runCmd: failed to exec '@{$cmd}': $!");
return wantarray ? () : '';
};
local $/ = undef;
$output = <$fh>;
close $fh;
} else {
# Scalar command runs via the shell; optionally merge stderr into stdout.
logMsg( "Scalar running command [$cmd]" );
my $c = $cmd;
$c .= ' 2>&1' if $merge_stderr;
$output = `$c`;
}
$output //= '';
if (wantarray) {
return $output eq '' ? () : split(/\n/, $output);
} else {
return $output;
}
}
# this calls gshred which will overwrite the file 3 times, then
# remove it.
# NOTE: this will not work on ZFS, since ZFS is CopyOnWrite (COW)
# so assuming file is on something without COW (ramdisk, UFS, etc)
sub shredFile {
my $filename = shift;
`/usr/local/bin/gshred -u -f -s 32 $filename` if -e $filename;
}
sub logMsg {
my $msg = shift;
my $filename = shift // $logFileName;
my $timeStampFormat = shift // '%Y-%m-%d %H:%M:%S';
my $timestamp = strftime($timeStampFormat, localtime());
if (defined $filename && $filename ne '' ) {
open my $logfh, '>>', $filename or die "Could not open log file $filename: $!\n";
print $logfh "$timestamp\t$msg\n";
close $logfh;
}
print "$timestamp\t$msg\n" if ($displayLogsOnConsole);
}
# find a drive by it's label by scanning /dev/gpt/ for $timeout seconds.
# If the drive is found, mount it on mountPath and return the mountPath.
# If not found, return empty string.
sub mountDriveByLabel {
my ($label, $mountPath, $timeout, $checkEvery ) = @_;
unless ($label) {
logMsg("mountDriveByLabel: No label provided");
return '';
}
unless ( $label =~ /^[a-zA-Z0-9_\-]+$/ ) {
logMsg("mountDriveByLabel: Invalid label '$label'");
return '';
}
logMsg("mountDriveByLabel: Looking for drive with label '$label'");
# default to /mnt/label if not provided
$mountPath //= "/mnt/$label"; # this is where we'll mount it if we find it
$label = "/dev/gpt/$label"; # this is where FreeBSD puts gpt labeled drives
# default to 10 minutes (600 seconds) if not provided
$timeout //= 600;
# default to checking every minute if not provided
$checkEvery //= 60;
# wait up to $timeout seconds for device to appear, checking every 10 seconds
while ( $timeout > 0 ) {
if ( -e "$label" ) {
last;
} else {
sleep $checkEvery;
$timeout -= $checkEvery;
}
}
# if we found it, mount and return mount path
if ( -e "$label" ) {
# ensure mount point
unless ( -d $mountPath || make_path($mountPath) ) {
logMsg("Failed to create $mountPath: $!");
return '';
}
# mount device (let mount detect filesystem)
unless ( system('mount', $label, $mountPath) == 0 ) {
logMsg("Failed to mount $label on $mountPath: $!");
return '';
}
return $mountPath;
} else {
return '';
}
}
## Load a YAML configuration file into a hashref.
## If the file does not exist, and a default hashref is provided,
## create the file by dumping the default to YAML, then return the default.
sub loadConfig {
my ($filename, $default) = @_;
# If no filename was provided, return default or empty hashref
die "No filename provided to loadConfig\n" unless defined $filename;
# If file doesn't exist but a default hashref was provided, try to
# create the file by dumping the default to YAML, then return the default.
unless (-e $filename) {
logMsg("Config file $filename does not exist. Creating it with default values.");
if ($default && ref $default eq 'HASH') {
my $wrote = 0;
eval {
require YAML::XS;
YAML::XS->import();
YAML::XS::DumpFile($filename, $default);
$wrote = 1;
1;
} or do {
eval {
require YAML::Tiny;
YAML::Tiny->import();
my $yt = YAML::Tiny->new($default);
$yt->write($filename);
$wrote = 1;
1;
} or do {
logMsg("No YAML writer available (YAML::XS or YAML::Tiny). Could not create $filename");
};
};
die "Failed to write default config to $filename:$!\n" unless $wrote;
}
# No default provided; nothing to create
return {};
}
my $yaml;
# Try YAML::XS first, fall back to YAML::Tiny
eval {
require YAML::XS;
YAML::XS->import();
$yaml = YAML::XS::LoadFile($filename);
logMsg("using YAML::XS to load $filename");
1;
} or do {
eval {
require YAML::Tiny;
YAML::Tiny->import();
$yaml = YAML::Tiny->read($filename);
$yaml = $yaml->[0] if $yaml; # YAML::Tiny returns an arrayref of documents
logMsg("using YAML::Tiny to load $filename");
1;
} or do {
logMsg("No YAML parser installed (YAML::XS or YAML::Tiny). Skipping config load from $filename");
return ($default && ref $default eq 'HASH') ? $default : {};
};
};
# Ensure we have a hashref
die "Config file $filename did not produce a HASH.\n" unless (defined $yaml && ref $yaml eq 'HASH');
return $yaml;
}
sub mountGeli {
my $geliConfig = shift;
unless ( -e $geliConfig->{'localKey'} ) {
logMsg "Could not find local key file: " . $geliConfig->{'localKey'} . "\n";
return '';
}
# find the keyfile disk and mount it
my $path = mountDriveByLabel( $geliConfig->{'keydiskname'} );
unless ( $path ne '' and -e "$path/" . $geliConfig->{'keyfile'} ) {
logMsg "Could not find or mount keyfile disk with label: " . $geliConfig->{'keydiskname'} . "\n";
return '';
}
# create the combined geli keyfile in target location
unless ( makeGeliKey( "$path/" . $geliConfig->{'keyfile'}, $geliConfig->{'localKey'}, $geliConfig->{'target'} ) ) {
logMsg "Could not create geli keyfile\n";
return '';
}
# decrypt and mount the geli disks and zfs pool
my $poolname = decryptAndMountGeli( $geliConfig );
return $poolname;
}
## Decrypt each GELI disk from $geliConfig->{'diskList'} using the keyfile,
## then import and mount the ZFS pool specified in $geliConfig->{'poolname'}.
##
## Returns the pool name on success, empty on error.
sub decryptAndMountGeli {
my ($geliConfig) = @_;
# these are configuration sanity checks, so die if they fail
die "No disk list found in GELI config\n" unless $geliConfig->{'diskList'};
die "No pool name specified in config\n" unless $geliConfig->{'poolname'};
my $diskList = $geliConfig->{'diskList'};
my $poolname = $geliConfig->{'poolname'};
my $keyfile = $geliConfig->{'target'};
unless ( -e $keyfile ) {
logMsg "GELI keyfile $keyfile does not exist\n";
return '';
}
my @decrypted_devices;
# Decrypt each disk in the list
foreach my $disk (@{$diskList}) {
unless ( -e $disk ) {
logMsg "Disk $disk does not exist\n";
return '';
}
# Derive the decrypted device name (.eli suffix on FreeBSD)
my $decrypted = $disk . '.eli';
# Decrypt using geli attach with the keyfile
logMsg("Decrypting $disk with keyfile $keyfile");
if ( my $result = system('geli', 'attach', '-k', $keyfile, $disk) == 0 ) {
logMsg "Failed to decrypt $disk (exit $result)\n";
return '';
}
unless ( -e $decrypted ) {
logMsg "Decrypted device $decrypted does not exist after geli attach\n";
return '';
}
push @decrypted_devices, $decrypted;
}
# Import the ZFS pool
logMsg("Importing ZFS pool $poolname");
my @import_cmd = ('zpool', 'import');
# If decrypted devices exist, add their directories to -d list
foreach my $dev (@decrypted_devices) {
my $dir = $dev;
$dir =~ s!/[^/]+$!!; # Remove filename to get directory
push @import_cmd, '-d', $dir;
}
push @import_cmd, $poolname;
my $result = system(@import_cmd);
unless ( $result == 0 ) {
logMsg("Failed to import zfs pool $poolname (exit $result)\n");
return '';
}
# Mount the ZFS pool (zfs mount -a mounts all filesystems in the pool)
logMsg("Mounting ZFS pool $poolname");
$result = system('zfs', 'mount', '-a');
unless ( $result == 0 ) {
logMsg("Failed to mount zfs pool $poolname (exit $result)\n");
return '';
}
logMsg("Successfully decrypted and mounted pool $poolname");
return $poolname;
}
## Create a GELI key by XOR'ing a remote binary keyfile and a local key (hex string).
##
## Arguments:
## $remote_keyfile - path to binary keyfile (32 bytes)
## $localKeyHexOrPath - hex string (64 hex chars) or path to file containing hex
## $target - path to write the resulting 32-byte binary key
##
## Returns true on success, dies on fatal error.
sub makeGeliKey {
my ($remote_keyfile, $localKeyHexOrPath, $target) = @_;
die "remote keyfile not provided" unless defined $remote_keyfile;
die "local key not provided" unless defined $localKeyHexOrPath;
die "target not provided" unless defined $target;
die "Remote keyfile $remote_keyfile does not exist\n" unless -e $remote_keyfile;
# Read remote binary key
open my $rh, '<:raw', $remote_keyfile or die "Unable to open $remote_keyfile: $!\n";
my $rbuf;
my $read = read($rh, $rbuf, 32);
close $rh;
die "Failed to read 32 bytes from $remote_keyfile (got $read)\n" unless defined $read && $read == 32;
# Get local hex string (either direct string or file contents)
my $hex;
if (-e $localKeyHexOrPath) {
open my $lh, '<', $localKeyHexOrPath or die "Unable to open local key file $localKeyHexOrPath: $!\n";
local $/ = undef;
$hex = <$lh>;
close $lh;
} else {
$hex = $localKeyHexOrPath;
}
# clean hex (remove whitespace/newlines and optional 0x)
$hex =~ s/0x//g;
$hex =~ s/[^0-9a-fA-F]//g;
die "Local key must be 64 hex characters (256-bit)\n" unless length($hex) == 64;
my $lbuf = pack('H*', $hex);
die "Local key decoded to unexpected length " . length($lbuf) . "\n" unless length($lbuf) == 32;
# XOR the two buffers
my $out = '';
for my $i (0 .. 31) {
$out .= chr( ord(substr($rbuf, $i, 1)) ^ ord(substr($lbuf, $i, 1)) );
}
# Ensure target directory exists
my ($vol, $dirs, $file) = ($target =~ m{^(/?)(.*/)?([^/]+)$});
if ($dirs) {
my $dir = $dirs;
$dir =~ s{/$}{};
unless (-d $dir) {
require File::Path;
File::Path::make_path($dir) or die "Failed to create directory $dir: $!\n";
}
}
# Write out binary key and protect permissions
open my $oh, '>:raw', $target or die "Unable to open $target for writing: $!\n";
print $oh $out or die "Failed to write to $target: $!\n";
close $oh;
chmod 0600, $target;
return 1;
}
sub makeReplicateCommands {
my ($sourceSnapsRef, $statusRef, $newStatusRef) = @_;
$sourceSnapsRef ||= [];
$statusRef ||= [];
$newStatusRef ||= [];
# parse snapshots: each line is expected to have snapshot fullname as first token: pool/fs@snap ...
my %snaps_by_fs;
foreach my $line (@$sourceSnapsRef) {
next unless defined $line && $line =~ /\S/;
my ($tok) = split /\s+/, $line;
next unless $tok && $tok =~ /@/;
my ($fs, $snap) = split /@/, $tok, 2;
push @{ $snaps_by_fs{$fs} }, $snap;
}
# nothing to do
return [] unless keys %snaps_by_fs;
# figure root filesystem: first snapshot line's fs is the requested root
my ($first_line) = grep { defined $_ && $_ =~ /\S/ } @$sourceSnapsRef;
my ($root_fs) = $first_line ? (split(/\s+/, $first_line))[0] =~ /@/ ? (split(/@/, (split(/\s+/, $first_line))[0]))[0] : undef : undef;
$root_fs ||= (sort keys %snaps_by_fs)[0];
# helper: find last status entry for a filesystem (status lines contain full snapshot names pool/fs@snap)
my %last_status_for;
for my $s (@$statusRef) {
next unless $s && $s =~ /@/;
my ($fs, $snap) = split /@/, $s, 2;
$last_status_for{$fs} = $snap; # later entries override earlier ones -> last occurrence kept
}
# build per-filesystem "from" and "to"
my %from_for;
my %to_for;
foreach my $fs (keys %snaps_by_fs) {
my $arr = $snaps_by_fs{$fs};
next unless @$arr;
$to_for{$fs} = $arr->[-1];
$from_for{$fs} = $last_status_for{$fs}; # may be undef -> full send required
}
# decide if we can do a single recursive send:
# condition: all 'to' snapshot names are identical
my %to_names = map { $_ => 1 } values %to_for;
my $single_to_name = (keys %to_names == 1) ? (keys %to_names)[0] : undef;
my @commands;
if ($single_to_name) {
# check whether any from is missing
my @from_values = map { $from_for{$_} } sort keys %from_for;
my $any_from_missing = grep { !defined $_ } @from_values;
my %from_names = map { $_ => 1 } grep { defined $_ } @from_values;
my $single_from_name = (keys %from_names == 1) ? (keys %from_names)[0] : undef;
if ($any_from_missing) {
# full recursive send from root
push @commands, sprintf('zfs send -R %s@%s', $root_fs, $single_to_name);
}
elsif ($single_from_name) {
# incremental recursive send
push @commands, sprintf('zfs send -R -I %s@%s %s@%s',
$root_fs, $single_from_name, $root_fs, $single_to_name);
}
else {
# from snapshots differ across children -> fall back to per-filesystem sends
foreach my $fs (sort keys %to_for) {
my $to = $to_for{$fs};
my $from = $from_for{$fs};
if ($from) {
push @commands, sprintf('zfs send -I %s@%s %s@%s', $fs, $from, $fs, $to);
} else {
push @commands, sprintf('zfs send %s@%s', $fs, $to);
}
}
}
# update new status: record newest snap for every filesystem
foreach my $fs (keys %to_for) {
push @$newStatusRef, sprintf('%s@%s', $fs, $to_for{$fs});
}
} else {
# not all children share same newest snap -> per-filesystem sends
foreach my $fs (sort keys %to_for) {
my $to = $to_for{$fs};
my $from = $from_for{$fs};
if ($from) {
push @commands, sprintf('zfs send -I %s@%s %s@%s', $fs, $from, $fs, $to);
} else {
push @commands, sprintf('zfs send %s@%s', $fs, $to);
}
push @$newStatusRef, sprintf('%s@%s', $fs, $to);
}
}
# return arrayref of commands (caller can iterate or join with pipes)
return \@commands;
}
1;