Subversion Repositories zfs_utils

# Simplified BSD License (FreeBSD License)

#

# Copyright (c) 2025, Daily Data Inc.

# All rights reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions are met:

#

# 1. Redistributions of source code must retain the above copyright notice, this

#    list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright notice,

#    this list of conditions and the following disclaimer in the documentation

#    and/or other materials provided with the distribution.

#

# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

package ZFS_Utils;

use strict;

use warnings;

use Exporter 'import';

use Data::Dumper;

use POSIX qw(strftime);

use File::Path qw(make_path);

# library of ZFS related utility functions

# Copyright 2024 Daily Data Inc. <rodo@dailydata.net>

# currently used for sneakernet scripts, but plans to expand to other ZFS related tasks

# functions include:

#   runCmd: execute a command and return its output

#   shredFile: securely delete a file using gshred

#   logMsg: log messages to a log file and optionally to console

#   mountDriveByLabel: find and mount a drive by its GPT label

#   loadConfig: load a YAML configuration file into a hashref

#   mountGeli: decrypt and mount a GELI encrypted ZFS pool

#   makeGeliKey: create a GELI key by XOR'ing a remote binary keyfile and a local hex key

#   decryptAndMountGeli: decrypt GELI disks and mount the ZFS pool

#   findGeliDisks: find available disks for GELI/ZFS use

#   makeReplicateCommands: create zfs send commands for replication based on snapshot lists

# Exported functions and variables

our @EXPORT_OK = qw(loadConfig shredFile mountDriveByLabel mountGeli logMsg runCmd makeReplicateCommands $logFileName $displayLogsOnConsole);

our $VERSION = '0.2';

our $logFileName = '/tmp/zfs_utils.log'; # this can be overridden by the caller, and turned off with empty string

our $displayLogsOnConsole = 1; # if non-zero, log messages are also printed to console

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 undef on failure and logs failure message.

sub runCmd {

   my $cmd = join( ' ', @_ );

   $merge_stderr = 1 unless defined $merge_stderr;

   my $output = '';

   logMsg( "Running command [$cmd]" );

   $cmd .= ' 2>&1' if $merge_stderr;

   $output = `$cmd`;

   if ($? == -1) {

      logMsg( "failed to execute: $!");

      return ''

   }

   elsif ($? & 127) { # fatal error, exit program

      logMsg( sprintf( "child died with signal %d, %s coredump\n", ($? & 127),  ($? & 128) ? 'with' : 'without' ) );

      die;

   }

   else {

      logMsg( sprintf( "child exited with value %d\n", $? >> 8 ) );

   }

   $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, $filesystem ) = @_;

   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

   $filesystem //= 'ufs'; # default to mounting ufs

   # The location for the label depends on filesystem. Only providing access to ufs and msdos here for safety.

   # gpt labeled drives for ufs are in /dev/gpt/, for msdosfs in /dev/msdosfs/

   $label = $filesystem eq 'msdos' ? "/dev/msdosfs/$label" : "/dev/gpt/$label"; 

   # drive already mounted, just return the path

   return $mountPath if ( runCmd( "mount | grep '$mountPath'" ) );

   # default to 10 minutes (600 seconds) if not provided

   $timeout //= 600;

   # default to checking every minute if not provided

   $checkEvery //= 15;

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

         print "Waiting for drive labeled $label\n";

      }

    }

    # 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 ( runCmd( "mount -t $filesystem $label $mountPath" ) ) {

         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 ( $geliConfig->{'localKey'} ) {

      logMsg "Could not find local key in configuration file\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;

}

# find all disks which are candidates for use with geli/zfs

# Grabs all disks on the system, then removes those with partitions

# and those already used in zpools.

sub findGeliDisks {

   logMsg("Finding available disks for GELI/ZFS use");

   # get all disks in system

   my %allDisks = map{ chomp $_ ; $_ => 1 } runCmd( "geom disk list | grep 'Geom name:' | rev | cut -d' ' -f1 | rev" );

   # get the disks with partitions

   my @temp = runCmd( "gpart show -p | grep '^=>'");  # -p prints just the disks without partitions

   # remove them from the list

   foreach my $disk ( @temp ) {

      $allDisks{$1} = 0 if ( $disk =~ m/^=>[\t\s0-9]+([a-z][a-z0-9]+)/ ) ;

   }

   # get disk which are currently used for zpools

   @temp = runCmd( "zpool status -LP | grep '/dev/'" );

   foreach my $disk ( @temp ) {

      $allDisks{$1} = 0 if  $disk =~ m|/dev/([a-z]+\d+)|;

   }

   # return only the disks which are free (value 1)

   return grep{ $allDisks{$_} == 1 } keys %allDisks;

}

## 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) = @_;

   # Can't continue at all if no pool name

   die "No pool name specified in config\n" unless $geliConfig->{'poolname'};

   # if no list of disks provided, try to find them

   $geliConfig->{'diskList'} //= findGeliDisks();

   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 (@{$geliConfig->{'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', $geliConfig->{'target'}, $disk) == 0 ) {

         logMsg "Failed to decrypt $disk (exit $result)\n";

         next; # ignore failed disks and continue to see if we can import the pool

      }

      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

         $commands{'root_fs'} = sprintf('zfs send -R %s@%s', $root_fs, $single_to_name);

      }

      elsif ($single_from_name) {

         # incremental recursive send, but don't do it if they are the same

         $commands{$root_fs} = sprintf('zfs send -R -I %s@%s %s@%s',

                           $root_fs, $single_from_name, $root_fs, $single_to_name)

                           unless $single_from_name eq $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) {

               # if from and to are different, add it

               $commands{$fs} = sprintf('zfs send -I %s@%s %s@%s', $fs, $from, $fs, $to)

                  unless $from eq $to;

            } else {

               $commands{$fs} = 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) {

            $commands{$fs} = sprintf('zfs send -I %s@%s %s@%s', $fs, $from, $fs, $to);

         } else {

            $commands{$fs} = 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;